/* * tclCompile.h -- * * Copyright (c) 1996-1998 Sun Microsystems, Inc. * Copyright (c) 1998-2000 by Scriptics Corporation. * Copyright (c) 2001 by Kevin B. Kenny. All rights reserved. * Copyright (c) 2007 Daniel A. Steffen * Copyright (c) 2025 Donal K. Fellows * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #ifndef _TCLCOMPILATION #define _TCLCOMPILATION 1 #include "tclInt.h" struct ByteCode; /* Forward declaration. */ /* *------------------------------------------------------------------------ * Variables related to compilation. These are used in tclCompile.c, * tclExecute.c, tclBasic.c, and their clients. *------------------------------------------------------------------------ */ #ifdef TCL_COMPILE_DEBUG /* * 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". */ MODULE_SCOPE int tclTraceCompile; enum TclTraceBytecodeCompileLevels { TCL_TRACE_BYTECODE_COMPILE_NONE = 0, TCL_TRACE_BYTECODE_COMPILE_SUMMARY = 1, TCL_TRACE_BYTECODE_COMPILE_DETAIL = 2 }; /* * Variable that controls whether execution tracing is enabled and, if so, * what level of tracing is desired: * 0: no execution tracing * 1: trace invocations of Tcl procs only * 2: trace invocations of all (not compiled away) commands * 3: display each instruction executed * This variable is linked to the Tcl variable "tcl_traceExec". */ MODULE_SCOPE int tclTraceExec; enum TclTraceBytecodeExecLevels { TCL_TRACE_BYTECODE_EXEC_NONE = 0, TCL_TRACE_BYTECODE_EXEC_PROCS = 1, TCL_TRACE_BYTECODE_EXEC_COMMANDS = 2, TCL_TRACE_BYTECODE_EXEC_INSTRUCTIONS = 3 }; #endif /* * The type of lambda expressions. Note that every lambda will *always* have a * string representation. */ MODULE_SCOPE const Tcl_ObjType tclLambdaType; /* *------------------------------------------------------------------------ * Data structures related to compilation. *------------------------------------------------------------------------ */ /* * The type of indices into the local variable table. */ typedef Tcl_Size Tcl_LVTIndex; /* * The type of handles made by TclCreateAuxData() */ typedef Tcl_Size Tcl_AuxDataRef; /* * The type of "catch ranges" returned from TclCreateExceptRange(), etc. */ typedef Tcl_Size Tcl_ExceptionRange; /* * The structure used to implement Tcl "exceptions" (exceptional returns): for * example, those generated in loops by the break and continue commands, and * those generated by scripts and caught by the catch command. This * ExceptionRange structure describes a range of code (e.g., a loop body), the * kind of exceptions (e.g., a break or continue) that might occur, and the PC * offsets to jump to if a matching exception does occur. Exception ranges can * nest so this structure includes a nesting level that is used at runtime to * find the closest exception range surrounding a PC. For example, when a * break command is executed, the ExceptionRange structure for the most deeply * nested loop, if any, is found and used. These structures are also generated * for the "next" subcommands of for loops since a break there terminates the * for command. This means a for command actually generates two LoopInfo * structures. */ typedef enum { LOOP_EXCEPTION_RANGE, /* Exception's range is part of a loop. Break * and continue "exceptions" cause jumps to * appropriate PC offsets. */ CATCH_EXCEPTION_RANGE /* Exception's range is controlled by a catch * command. Errors in the range cause a jump * to a catch PC offset. */ } ExceptionRangeType; typedef struct ExceptionRange { ExceptionRangeType type; /* The kind of ExceptionRange. */ Tcl_Size nestingLevel; /* Static depth of the exception range. Used * to find the most deeply-nested range * surrounding a PC at runtime. */ Tcl_Size codeOffset; /* Offset of the first instruction byte of the * code range. */ Tcl_Size numCodeBytes; /* Number of bytes in the code range. */ Tcl_Size breakOffset; /* If LOOP_EXCEPTION_RANGE, the target PC * offset for a break command in the range. */ Tcl_Size continueOffset; /* If LOOP_EXCEPTION_RANGE and not TCL_INDEX_NONE, * the target PC offset for a continue command * in the code range. Otherwise, ignore this * range when processing a continue * command. */ Tcl_Size catchOffset; /* If a CATCH_EXCEPTION_RANGE, the target PC * offset for any "exception" in range. */ } ExceptionRange; /* * Auxiliary data used when issuing (currently just loop) exception ranges, * but which is not required during execution. */ typedef struct ExceptionAux { int supportsContinue; /* Whether this exception range will have a * continueOffset created for it; if it is a * loop exception range that *doesn't* have * one (see [for] next-clause) then we must * not pick up the range when scanning for a * target to continue to. */ Tcl_Size stackDepth; /* The stack depth at the point where the * exception range was created. This is used * to calculate the number of POPs required to * restore the stack to its prior state. */ Tcl_Size expandTarget; /* The number of expansions expected on the * auxData stack at the time the loop starts; * we can't currently discard them except by * doing INST_INVOKE_EXPANDED; this is a known * problem. */ Tcl_Size expandTargetDepth; /* The stack depth expected at the outermost * expansion within the loop. Not meaningful * if there are no open expansions between the * looping level and the point of jump * issue. */ Tcl_Size numBreakTargets; /* The number of [break]s that want to be * targeted to the place where this loop * exception will be bound to. */ size_t *breakTargets; /* The offsets of the INST_JUMP instructions * issued by the [break]s that we must * update. Note that resizing a jump (via * TclFixupForwardJump) can cause the contents * of this array to be updated. When * numBreakTargets==0, this is NULL. */ Tcl_Size allocBreakTargets; /* The size of the breakTargets array. */ Tcl_Size numContinueTargets;/* The number of [continue]s that want to be * targeted to the place where this loop * exception will be bound to. */ size_t *continueTargets; /* The offsets of the INST_JUMP instructions * issued by the [continue]s that we must * update. Note that resizing a jump (via * TclFixupForwardJump) can cause the contents * of this array to be updated. When * numContinueTargets==0, this is NULL. */ Tcl_Size allocContinueTargets; /* The size of the continueTargets array. */ } ExceptionAux; /* * Structure used to map between instruction pc and source locations. It * defines for each compiled Tcl command its code's starting offset and its * source's starting offset and length. Note that the code offset increases * monotonically: that is, the table is sorted in code offset order. The * source offset is not monotonic. */ typedef struct CmdLocation { Tcl_Size codeOffset; /* Offset of first byte of command code. */ Tcl_Size numCodeBytes; /* Number of bytes for command's code. */ Tcl_Size srcOffset; /* Offset of first char of the command. */ Tcl_Size numSrcBytes; /* Number of command source chars. */ } CmdLocation; /* * TIP #280 * Structure to record additional location information for byte code. This * information is internal and not saved. i.e. tbcload'ed code will not have * this information. It records the lines for all words of all commands found * in the byte code. The association with a ByteCode structure BC is done * through the 'lineBCPtr' HashTable in Interp, keyed by the address of BC. * Also recorded is information coming from the context, i.e. type of the * frame and associated information, like the path of a sourced file. */ typedef struct ECL { Tcl_Size srcOffset; /* Command location to find the entry. */ Tcl_Size nline; /* Number of words in the command */ int *line; /* Line information for all words in the * command. */ Tcl_Size **next; /* Transient information used by the compiler * for tracking of hidden continuation * lines. */ } ECL; typedef struct ExtCmdLoc { int type; /* Context type. */ Tcl_Size start; /* Starting line for compiled script. Needed * for the extended recompile check in * tclCompileObj. */ Tcl_Obj *path; /* Path of the sourced file the command is * in. */ ECL *loc; /* Command word locations (lines). */ Tcl_Size nloc; /* Number of allocated entries in 'loc'. */ Tcl_Size nuloc; /* Number of used entries in 'loc'. */ } ExtCmdLoc; /* * CompileProcs need the ability to record information during compilation that * can be used by bytecode instructions during execution. The AuxData * structure provides this "auxiliary data" mechanism. An arbitrary number of * these structures can be stored in the ByteCode record (during compilation * they are stored in a CompileEnv structure). Each AuxData record holds one * word of client-specified data (often a pointer) and is given an index that * instructions can later use to look up the structure and its data. * * The following definitions declare the types of procedures that are called * to duplicate or free this auxiliary data when the containing ByteCode * objects are duplicated and freed. Pointers to these procedures are kept in * the AuxData structure. */ typedef void * (AuxDataDupProc) (void *clientData); typedef void (AuxDataFreeProc) (void *clientData); typedef void (AuxDataPrintProc) (void *clientData, Tcl_Obj *appendObj, struct ByteCode *codePtr, size_t pcOffset); /* * We define a separate AuxDataType struct to hold type-related information * for the AuxData structure. This separation makes it possible for clients * outside of the TCL core to manipulate (in a limited fashion!) AuxData; for * example, it makes it possible to pickle and unpickle AuxData structs. */ typedef struct AuxDataType { const char *name; /* The name of the type. Types can be * registered and found by name */ AuxDataDupProc *dupProc; /* Callback procedure to invoke when the aux * data is duplicated (e.g., when the ByteCode * structure containing the aux data is * duplicated). NULL means just copy the * source clientData bits; no proc need be * called. */ AuxDataFreeProc *freeProc; /* Callback procedure to invoke when the aux * data is freed. NULL means no proc need be * called. */ AuxDataPrintProc *printProc;/* Callback function to invoke when printing * the aux data as part of debugging. NULL * means that the data can't be printed. */ AuxDataPrintProc *disassembleProc; /* Callback function to invoke when doing a * disassembly of the aux data (like the * printProc, except that the output is * intended to be script-readable). The * appendObj argument should be filled in with * a descriptive dictionary; it will start out * with "name" mapped to the content of the * name field. NULL means that the printProc * should be used instead. */ } AuxDataType; /* * The definition of the AuxData structure that holds information created * during compilation by CompileProcs and used by instructions during * execution. */ typedef struct AuxData { const AuxDataType *type; /* Pointer to the AuxData type associated with * this ClientData. */ void *clientData; /* The compilation data itself. */ } AuxData; /* * Structure defining the compilation environment. After compilation, fields * describing bytecode instructions are copied out into the more compact * ByteCode structure defined below. */ #define COMPILEENV_INIT_CODE_BYTES 250 #define COMPILEENV_INIT_NUM_OBJECTS 60 #define COMPILEENV_INIT_EXCEPT_RANGES 5 #define COMPILEENV_INIT_CMD_MAP_SIZE 40 #define COMPILEENV_INIT_AUX_DATA_SIZE 5 typedef struct CompileEnv { Interp *iPtr; /* Interpreter containing the code being * compiled. Commands and their compile procs * are specific to an interpreter so the code * emitted will depend on the interpreter. */ const char *source; /* The source string being compiled by * SetByteCodeFromAny. This pointer is not * owned by the CompileEnv and must not be * freed or changed by it. */ Tcl_Size numSrcBytes; /* Number of bytes in source. */ Proc *procPtr; /* If a procedure is being compiled, a pointer * to its Proc structure; otherwise NULL. Used * to compile local variables. Set from * information provided by ObjInterpProc in * tclProc.c. */ Tcl_Size numCommands; /* Number of commands compiled. */ Tcl_Size exceptDepth; /* Current exception range nesting level; * TCL_INDEX_NONE if not in any range * currently. */ Tcl_Size maxExceptDepth; /* Max nesting level of exception ranges; * TCL_INDEX_NONE if no ranges have been * compiled. */ Tcl_Size maxStackDepth; /* Maximum number of stack elements needed to * execute the code. Set by compilation * procedures before returning. */ Tcl_Size currStackDepth; /* Current stack depth. */ LiteralTable localLitTable; /* Contains LiteralEntry's describing all Tcl * objects referenced by this compiled code. * Indexed by the string representations of * the literals. Used to avoid creating * duplicate objects. */ unsigned char *codeStart; /* Points to the first byte of the code. */ unsigned char *codeNext; /* Points to next code array byte to use. */ unsigned char *codeEnd; /* Points just after the last allocated code * array byte. */ int mallocedCodeArray; /* Set 1 if code array was expanded and * codeStart points into the heap.*/ int mallocedExceptArray; /* 1 if ExceptionRange array was expanded and * exceptArrayPtr points in heap, else 0. */ LiteralEntry *literalArrayPtr; /* Points to start of LiteralEntry array. */ Tcl_Size literalArrayNext; /* Index of next free object array entry. */ Tcl_Size literalArrayEnd; /* Index just after last obj array entry. */ int mallocedLiteralArray; /* 1 if object array was expanded and objArray * points into the heap, else 0. */ ExceptionRange *exceptArrayPtr; /* Points to start of the ExceptionRange * array. */ Tcl_Size exceptArrayNext; /* Next free ExceptionRange array index. * exceptArrayNext is the number of ranges and * (exceptArrayNext-1) is the index of the * current range's array entry. */ Tcl_Size exceptArrayEnd; /* Index after the last ExceptionRange array * entry. */ ExceptionAux *exceptAuxArrayPtr; /* Array of information used to restore the * state when processing BREAK/CONTINUE * exceptions. Must be the same size as the * exceptArrayPtr. */ CmdLocation *cmdMapPtr; /* Points to start of CmdLocation array. * numCommands is the index of the next entry * to use; (numCommands-1) is the entry index * for the last command. */ Tcl_Size cmdMapEnd; /* Index after last CmdLocation entry. */ int mallocedCmdMap; /* 1 if command map array was expanded and * cmdMapPtr points in the heap, else 0. */ int mallocedAuxDataArray; /* 1 if aux data array was expanded and * auxDataArrayPtr points in heap else 0. */ AuxData *auxDataArrayPtr; /* Points to auxiliary data array start. */ Tcl_Size auxDataArrayNext; /* Next free compile aux data array index. * auxDataArrayNext is the number of aux data * items and (auxDataArrayNext-1) is index of * current aux data array entry. */ Tcl_Size auxDataArrayEnd; /* Index after last aux data array entry. */ unsigned char staticCodeSpace[COMPILEENV_INIT_CODE_BYTES]; /* Initial storage for code. */ LiteralEntry staticLiteralSpace[COMPILEENV_INIT_NUM_OBJECTS]; /* Initial storage of LiteralEntry array. */ ExceptionRange staticExceptArraySpace[COMPILEENV_INIT_EXCEPT_RANGES]; /* Initial ExceptionRange array storage. */ ExceptionAux staticExAuxArraySpace[COMPILEENV_INIT_EXCEPT_RANGES]; /* Initial static except auxiliary info array * storage. */ CmdLocation staticCmdMapSpace[COMPILEENV_INIT_CMD_MAP_SIZE]; /* Initial storage for cmd location map. */ AuxData staticAuxDataArraySpace[COMPILEENV_INIT_AUX_DATA_SIZE]; /* Initial storage for aux data array. */ /* TIP #280 */ ExtCmdLoc *extCmdMapPtr; /* Extended command location information for * 'info frame'. */ int line; /* First line of the script, based on the * invoking context, then the line of the * command currently compiled. */ int atCmdStart; /* Flag to say whether an INST_START_CMD * should be issued; they should never be * issued repeatedly, as that is significantly * inefficient. If set to 2, that instruction * should not be issued at all (by the generic * part of the command compiler). */ Tcl_Size expandCount; /* Number of INST_EXPAND_START instructions * encountered that have not yet been paired * with a corresponding * INST_INVOKE_EXPANDED. */ Tcl_Size *clNext; /* If not NULL, it refers to the next slot in * clLoc to check for an invisible * continuation line. */ } CompileEnv; /* * Function to get the offset to the next instruction to be issued. * More mnemonic than just putting the calculation in directly. */ static inline Tcl_Size CurrentOffset( CompileEnv *envPtr) { return envPtr->codeNext - envPtr->codeStart; } /* * Information about what the current source line is. */ typedef struct LineInformation { ExtCmdLoc *mapPtr; /* Extended command location information for * 'info frame'. */ Tcl_Size eclIndex; /* Current index into mapPtr->loc. */ } LineInformation; /* * The structure defining the bytecode instructions resulting from compiling a * Tcl script. Note that this structure is variable length: a single heap * object is allocated to hold the ByteCode structure immediately followed by * the code bytes, the literal object array, the ExceptionRange array, the * CmdLocation map, and the compilation AuxData array. */ enum ByteCodeFlags { /* * A PRECOMPILED bytecode struct is one that was generated from a compiled * image rather than implicitly compiled from source */ TCL_BYTECODE_PRECOMPILED = 0x0001, /* * When a bytecode is compiled, interp or namespace resolvers have not been * applied yet: this is indicated by the TCL_BYTECODE_RESOLVE_VARS flag. */ TCL_BYTECODE_RESOLVE_VARS = 0x0002, /* * Used to note that a recompilation of the bytecode is believed necessary. * The recompilation may generate the same bytecode sequence, but we can't * prove that without doing it. */ TCL_BYTECODE_RECOMPILE = 0x0004 }; typedef struct ByteCode { TclHandle interpHandle; /* Handle for interpreter containing the * compiled code. Commands and their compile * procs are specific to an interpreter so the * code emitted will depend on the * interpreter. */ Tcl_Size compileEpoch; /* Value of iPtr->compileEpoch when this * ByteCode was compiled. Used to invalidate * code when, e.g., commands with compile * procs are redefined. */ Namespace *nsPtr; /* Namespace context in which this code was * compiled. If the code is executed if a * different namespace, it must be * recompiled. */ Tcl_Size nsEpoch; /* Value of nsPtr->resolverEpoch when this * ByteCode was compiled. Used to invalidate * code when new namespace resolution rules * are put into effect. */ Tcl_Size refCount; /* Reference count: set 1 when created plus 1 * for each execution of the code currently * active. This structure can be freed when * refCount becomes zero. */ unsigned int flags; /* flags describing state for the codebyte. * this variable holds OR'ed values from the * TCL_BYTECODE_ masks defined above */ const char *source; /* The source string from which this ByteCode * was compiled. Note that this pointer is not * owned by the ByteCode and must not be freed * or modified by it. */ Proc *procPtr; /* If the ByteCode was compiled from a * procedure body, this is a pointer to its * Proc structure; otherwise NULL. This * pointer is also not owned by the ByteCode * and must not be freed by it. */ size_t structureSize; /* Number of bytes in the ByteCode structure * itself. Does not include heap space for * literal Tcl objects or storage referenced * by AuxData entries. */ Tcl_Size numCommands; /* Number of commands compiled. */ Tcl_Size numSrcBytes; /* Number of source bytes compiled. */ Tcl_Size numCodeBytes; /* Number of code bytes. */ Tcl_Size numLitObjects; /* Number of objects in literal array. */ Tcl_Size numExceptRanges; /* Number of ExceptionRange array elems. */ Tcl_Size numAuxDataItems; /* Number of AuxData items. */ Tcl_Size numCmdLocBytes; /* Number of bytes needed for encoded command * location information. */ Tcl_Size maxExceptDepth; /* Maximum nesting level of ExceptionRanges; * TCL_INDEX_NONE if no ranges were compiled. */ Tcl_Size maxStackDepth; /* Maximum number of stack elements needed to * execute the code. */ unsigned char *codeStart; /* Points to the first byte of the code. This * is just after the final ByteCode member * cmdMapPtr. */ Tcl_Obj **objArrayPtr; /* Points to the start of the literal object * array. This is just after the last code * byte. */ ExceptionRange *exceptArrayPtr; /* Points to the start of the ExceptionRange * array. This is just after the last object * in the object array. */ AuxData *auxDataArrayPtr; /* Points to the start of the auxiliary data * array. This is just after the last entry in * the ExceptionRange array. */ unsigned char *codeDeltaStart; /* Points to the first of a sequence of bytes * that encode the change in the starting * offset of each command's code. If -127 <= * delta <= 127, it is encoded as 1 byte, * otherwise 0xFF (128) appears and the delta * is encoded by the next 4 bytes. Code deltas * are always positive. This sequence is just * after the last entry in the AuxData * array. */ unsigned char *codeLengthStart; /* Points to the first of a sequence of bytes * that encode the length of each command's * code. The encoding is the same as for code * deltas. Code lengths are always positive. * This sequence is just after the last entry * in the code delta sequence. */ unsigned char *srcDeltaStart; /* Points to the first of a sequence of bytes * that encode the change in the starting * offset of each command's source. The * encoding is the same as for code deltas. * Source deltas can be negative. This * sequence is just after the last byte in the * code length sequence. */ unsigned char *srcLengthStart; /* Points to the first of a sequence of bytes * that encode the length of each command's * source. The encoding is the same as for * code deltas. Source lengths are always * positive. This sequence is just after the * last byte in the source delta sequence. */ LocalCache *localCachePtr; /* Pointer to the start of the cached variable * names and initialisation data for local * variables. */ #ifdef TCL_COMPILE_STATS Tcl_Time createTime; /* Absolute time when the ByteCode was * created. */ #endif /* TCL_COMPILE_STATS */ } ByteCode; #define ByteCodeSetInternalRep(objPtr, typePtr, codePtr) \ do { \ Tcl_ObjInternalRep ir; \ ir.twoPtrValue.ptr1 = (codePtr); \ ir.twoPtrValue.ptr2 = NULL; \ Tcl_StoreInternalRep((objPtr), (typePtr), &ir); \ } while (0) #define ByteCodeGetInternalRep(objPtr, typePtr, codePtr) \ do { \ const Tcl_ObjInternalRep *irPtr; \ irPtr = TclFetchInternalRep((objPtr), (typePtr)); \ (codePtr) = irPtr ? (ByteCode*)irPtr->twoPtrValue.ptr1 : NULL; \ } while (0) /* * A special macro to allow an opcode in the TclInstruction enum to be marked * as deprecated. The tricky bit is that we do *not* want the opcodes to be * deprecated in the bytecode execution engine, disassembler or (for now) * optimizer; if ALLOW_DEPRECATED_OPCODES is defined prior to including this * file, DEPRECATED_OPCODE doesn't apply the deprecation marker. * * If REMOVE_DEPRECATED_OPCODES is defined, the opcodes are removed entirely * and will be wholly unusable, even by precompiled bytecode. */ #ifdef REMOVE_DEPRECATED_OPCODES #define DEPRECATED_OPCODE(name) JOIN(INST_DEPRECATED_, __LINE__) #elif defined(ALLOW_DEPRECATED_OPCODES) #define DEPRECATED_OPCODE(name) \ name #elif defined(__STDC_VERSION__) && __STDC_VERSION__ >= 202311L #define DEPRECATED_OPCODE(name) \ name [[deprecated("use 4-byte operand version instead")]] #elif defined(__GNUC__) || defined(__clang__) /* Technically missing guards for some very old gcc/clang versions. */ #define DEPRECATED_OPCODE(name) \ name __attribute__((deprecated ("use 4-byte operand version instead"))) #else #define DEPRECATED_OPCODE(name) \ name #endif /* * Opcodes for the Tcl bytecode instructions. These must correspond to the * entries in the table of instruction descriptions, tclInstructionTable, in * tclCompile.c. Also, the order and number of the expression opcodes (e.g., * INST_BITOR) must match the entries in the array operatorStrings in * tclExecute.c. */ enum TclInstruction { /* Opcodes 0 to 9 */ INST_DONE = 0, DEPRECATED_OPCODE(INST_PUSH1), INST_PUSH = 2, INST_POP, INST_DUP, INST_STR_CONCAT1, DEPRECATED_OPCODE(INST_INVOKE_STK1), INST_INVOKE_STK = 7, INST_EVAL_STK, INST_EXPR_STK, /* Opcodes 10 to 23 */ DEPRECATED_OPCODE(INST_LOAD_SCALAR1), INST_LOAD_SCALAR = 11, DEPRECATED_OPCODE(INST_LOAD_SCALAR_STK), // Not used DEPRECATED_OPCODE(INST_LOAD_ARRAY1), INST_LOAD_ARRAY = 14, INST_LOAD_ARRAY_STK, INST_LOAD_STK, DEPRECATED_OPCODE(INST_STORE_SCALAR1), INST_STORE_SCALAR = 18, DEPRECATED_OPCODE(INST_STORE_SCALAR_STK), // Not used DEPRECATED_OPCODE(INST_STORE_ARRAY1), INST_STORE_ARRAY = 21, INST_STORE_ARRAY_STK, INST_STORE_STK, /* Opcodes 24 to 33 */ DEPRECATED_OPCODE(INST_INCR_SCALAR1), INST_INCR_SCALAR_STK = 25, DEPRECATED_OPCODE(INST_INCR_ARRAY1), INST_INCR_ARRAY_STK = 27, INST_INCR_STK, DEPRECATED_OPCODE(INST_INCR_SCALAR1_IMM), INST_INCR_SCALAR_STK_IMM = 30, DEPRECATED_OPCODE(INST_INCR_ARRAY1_IMM), INST_INCR_ARRAY_STK_IMM = 32, INST_INCR_STK_IMM, /* Opcodes 34 to 39 */ DEPRECATED_OPCODE(INST_JUMP1), INST_JUMP = 35, DEPRECATED_OPCODE(INST_JUMP_TRUE1), INST_JUMP_TRUE = 37, DEPRECATED_OPCODE(INST_JUMP_FALSE1), INST_JUMP_FALSE = 39, /* Opcodes 42 to 60 */ INST_BITOR, INST_BITXOR, INST_BITAND, INST_EQ, INST_NEQ, INST_LT, INST_GT, INST_LE, INST_GE, INST_LSHIFT, INST_RSHIFT, INST_ADD, INST_SUB, INST_MULT, INST_DIV, INST_MOD, INST_UPLUS, INST_UMINUS, INST_BITNOT, INST_LNOT, INST_TRY_CVT_TO_NUMERIC, /* Opcodes 61 to 62 */ INST_BREAK, INST_CONTINUE, /* Opcodes 63 to 66 */ INST_BEGIN_CATCH, INST_END_CATCH, INST_PUSH_RESULT, INST_PUSH_RETURN_CODE, /* Opcodes 67 to 72 */ INST_STR_EQ, INST_STR_NEQ, INST_STR_CMP, INST_STR_LEN, INST_STR_INDEX, INST_STR_MATCH, /* Opcodes 73 to 75 */ INST_LIST, INST_LIST_INDEX, INST_LIST_LENGTH, /* Opcodes 76 to 81 */ DEPRECATED_OPCODE(INST_APPEND_SCALAR1), INST_APPEND_SCALAR = 77, DEPRECATED_OPCODE(INST_APPEND_ARRAY1), INST_APPEND_ARRAY = 79, INST_APPEND_ARRAY_STK, INST_APPEND_STK, /* Opcodes 82 to 87 */ DEPRECATED_OPCODE(INST_LAPPEND_SCALAR1), INST_LAPPEND_SCALAR = 83, DEPRECATED_OPCODE(INST_LAPPEND_ARRAY1), INST_LAPPEND_ARRAY = 85, INST_LAPPEND_ARRAY_STK, INST_LAPPEND_STK, /* TIP #22 - LINDEX operator with flat arg list */ INST_LIST_INDEX_MULTI, /* * TIP #33 - 'lset' command. Code gen also required a Forth-like * OVER operation. */ INST_OVER, INST_LSET_LIST, INST_LSET_FLAT, /* TIP#90 - 'return' command. */ INST_RETURN_IMM, /* TIP#123 - exponentiation operator. */ INST_EXPON, /* TIP #157 - {*}... (word expansion) language syntax support. */ INST_EXPAND_START, INST_EXPAND_STKTOP, INST_INVOKE_EXPANDED, /* * TIP #57 - 'lassign' command. Code generation requires immediate * LINDEX and LRANGE operators. */ INST_LIST_INDEX_IMM, INST_LIST_RANGE_IMM, INST_START_CMD, INST_LIST_IN, INST_LIST_NOT_IN, INST_PUSH_RETURN_OPTIONS, INST_RETURN_STK, /* * Dictionary (TIP#111) related commands. */ INST_DICT_GET, INST_DICT_SET, INST_DICT_UNSET, INST_DICT_INCR_IMM, INST_DICT_APPEND, INST_DICT_LAPPEND, INST_DICT_FIRST, INST_DICT_NEXT, INST_DICT_UPDATE_START, INST_DICT_UPDATE_END, /* * Instruction to support jumps defined by tables (instead of the classic * [switch] technique of chained comparisons). */ INST_JUMP_TABLE, /* * Instructions to support compilation of global, variable, upvar and * [namespace upvar]. */ INST_UPVAR, INST_NSUPVAR, INST_VARIABLE, /* Instruction to support compiling syntax error to bytecode */ INST_SYNTAX, /* Instruction to reverse N items on top of stack */ INST_REVERSE, /* regexp instruction */ INST_REGEXP, /* For [info exists] compilation */ INST_EXIST_SCALAR, INST_EXIST_ARRAY, INST_EXIST_ARRAY_STK, INST_EXIST_STK, /* For [subst] compilation */ INST_NOP, DEPRECATED_OPCODE(INST_RETURN_CODE_BRANCH), /* For [unset] compilation */ INST_UNSET_SCALAR = 127, INST_UNSET_ARRAY, INST_UNSET_ARRAY_STK, INST_UNSET_STK, /* For [dict with], [dict exists], [dict create] and [dict merge] */ INST_DICT_EXPAND, INST_DICT_RECOMBINE_STK, INST_DICT_RECOMBINE_IMM, INST_DICT_EXISTS, INST_DICT_VERIFY, /* For [string map] and [regsub] compilation */ INST_STR_MAP, INST_STR_FIND, INST_STR_FIND_LAST, INST_STR_RANGE_IMM, INST_STR_RANGE, /* For operations to do with coroutines and other NRE-manipulators */ INST_YIELD, INST_COROUTINE_NAME, DEPRECATED_OPCODE(INST_TAILCALL1), /* For compilation of basic information operations */ INST_NS_CURRENT = 144, INST_INFO_LEVEL_NUM, INST_INFO_LEVEL_ARGS, INST_RESOLVE_COMMAND, /* For compilation relating to TclOO */ INST_TCLOO_SELF, INST_TCLOO_CLASS, INST_TCLOO_NS, INST_TCLOO_IS_OBJECT, /* For compilation of [array] subcommands */ INST_ARRAY_EXISTS_STK, INST_ARRAY_EXISTS_IMM, INST_ARRAY_MAKE_STK, INST_ARRAY_MAKE_IMM, INST_INVOKE_REPLACE, INST_LIST_CONCAT, INST_EXPAND_DROP, /* New foreach implementation */ INST_FOREACH_START, INST_FOREACH_STEP, INST_FOREACH_END, INST_LMAP_COLLECT, /* For compilation of [string trim] and related */ INST_STR_TRIM, INST_STR_TRIM_LEFT, INST_STR_TRIM_RIGHT, INST_CONCAT_STK, INST_STR_UPPER, INST_STR_LOWER, INST_STR_TITLE, INST_STR_REPLACE, INST_ORIGIN_COMMAND, DEPRECATED_OPCODE(INST_TCLOO_NEXT1), DEPRECATED_OPCODE(INST_TCLOO_NEXT_CLASS1), INST_YIELD_TO_INVOKE = 174, INST_NUM_TYPE, INST_TRY_CVT_TO_BOOLEAN, INST_STR_CLASS, INST_LAPPEND_LIST, INST_LAPPEND_LIST_ARRAY, INST_LAPPEND_LIST_ARRAY_STK, INST_LAPPEND_LIST_STK, INST_CLOCK_READ, INST_DICT_GET_DEF, /* TIP 461 */ INST_STR_LT, INST_STR_GT, INST_STR_LE, INST_STR_GE, INST_LREPLACE, /* TIP 667: const */ INST_CONST_IMM, INST_CONST_STK, /* Updated compilations with fewer arg size constraints for 9.1 */ INST_INCR_SCALAR, INST_INCR_ARRAY, INST_INCR_SCALAR_IMM, INST_INCR_ARRAY_IMM, INST_TAILCALL, INST_TCLOO_NEXT, INST_TCLOO_NEXT_CLASS, /* Really new opcodes for 9.1 */ INST_SWAP, INST_ERROR_PREFIX_EQ, INST_TCLOO_ID, INST_DICT_PUT, INST_DICT_REMOVE, INST_IS_EMPTY, INST_JUMP_TABLE_NUM, INST_TAILCALL_LIST, INST_TCLOO_NEXT_LIST, INST_TCLOO_NEXT_CLASS_LIST, INST_ARITH_SERIES, INST_UPLEVEL, /* The last opcode */ LAST_INST_OPCODE }; /* * Table describing the Tcl bytecode instructions: their name (for displaying * code), total number of code bytes required (including operand bytes), and a * description of the type of each operand. These operand types include signed * and unsigned integers of length one and four bytes. The unsigned integers * are used for indexes or for, e.g., the count of objects to push in a "push" * instruction. */ #define MAX_INSTRUCTION_OPERANDS 2 typedef enum InstOperandType { OPERAND_NONE, OPERAND_INT1, /* One byte signed integer. */ OPERAND_INT4, /* Four byte signed integer. */ OPERAND_UINT1, /* One byte unsigned integer. */ OPERAND_UINT4, /* Four byte unsigned integer. */ OPERAND_IDX4, /* Four byte signed index (actually an * integer, but displayed differently.) */ OPERAND_LVT1, /* One byte unsigned index into the local * variable table. */ OPERAND_LVT4, /* Four byte unsigned index into the local * variable table. */ OPERAND_AUX4, /* Four byte unsigned index into the aux data * table. */ OPERAND_OFFSET1, /* One byte signed jump offset. */ OPERAND_OFFSET4, /* Four byte signed jump offset. */ OPERAND_LIT1, /* One byte unsigned index into table of * literals. */ OPERAND_LIT4, /* Four byte unsigned index into table of * literals. */ OPERAND_SCLS1, /* Index into tclStringClassTable. */ OPERAND_UNSF1, /* Flags for [unset] */ OPERAND_CLK1, /* Index into [clock] types. */ OPERAND_LRPL1 /* Combination of TCL_LREPLACE_* flags. */ } InstOperandType; typedef struct InstructionDesc { const char *name; /* Name of instruction. */ int numBytes; /* Total number of bytes for instruction. */ int stackEffect; /* The worst-case balance stack effect of the * instruction, used for stack requirements * computations. The value INT_MIN signals * that the instruction's worst case effect is * (1-opnd1). */ int numOperands; /* Number of operands. */ InstOperandType opTypes[MAX_INSTRUCTION_OPERANDS]; /* The type of each operand. */ } InstructionDesc; MODULE_SCOPE InstructionDesc const tclInstructionTable[]; /* * Constants used by INST_STRING_CLASS to indicate character classes. These * correspond closely by name with what [string is] can support, but there is * no requirement to keep the values the same. */ typedef enum InstStringClassType { STR_CLASS_ALNUM, /* Unicode alphabet or digit characters. */ STR_CLASS_ALPHA, /* Unicode alphabet characters. */ STR_CLASS_ASCII, /* Characters in range U+000000..U+00007F. */ STR_CLASS_CONTROL, /* Unicode control characters. */ STR_CLASS_DIGIT, /* Unicode digit characters. */ STR_CLASS_GRAPH, /* Unicode printing characters, excluding * space. */ STR_CLASS_LOWER, /* Unicode lower-case alphabet characters. */ STR_CLASS_PRINT, /* Unicode printing characters, including * spaces. */ STR_CLASS_PUNCT, /* Unicode punctuation characters. */ STR_CLASS_SPACE, /* Unicode space characters. */ STR_CLASS_UPPER, /* Unicode upper-case alphabet characters. */ STR_CLASS_WORD, /* Unicode word (alphabetic, digit, connector * punctuation) characters. */ STR_CLASS_XDIGIT, /* Characters that can be used as digits in * hexadecimal numbers ([0-9A-Fa-f]). */ } InstStringClassType; typedef struct StringClassDesc { char name[8]; /* Name of the class. */ int (*comparator)(int); /* Function to test if a single unicode * character is a member of the class. */ } StringClassDesc; MODULE_SCOPE StringClassDesc const tclStringClassTable[]; /* * Compilation of some Tcl constructs such as if commands and the logical or * (||) and logical and (&&) operators in expressions requires the generation * of forward jumps. Since the PC target of these jumps isn't known when the * jumps are emitted, we record the offset of each jump in an array of * JumpFixup structures. There is one array for each sequence of jumps to one * target PC. When we learn the target PC, we update the jumps with the * correct distance. Also, if the distance is too great (> 127 bytes), we * replace the single-byte jump with a four byte jump instruction, move the * instructions after the jump down, and update the code offsets for any * commands between the jump and the target. */ typedef enum { TCL_UNCONDITIONAL_JUMP, TCL_TRUE_JUMP, TCL_FALSE_JUMP } TclJumpType; typedef struct JumpFixup { TclJumpType jumpType; /* Indicates the kind of jump. */ unsigned int codeOffset; /* Offset of the first byte of the one-byte * forward jump's code. */ int cmdIndex; /* Index of the first command after the one * for which the jump was emitted. Used to * update the code offsets for subsequent * commands if the two-byte jump at jumpPc * must be replaced with a five-byte one. */ int exceptIndex; /* Index of the first range entry in the * ExceptionRange array after the current one. * This field is used to adjust the code * offsets in subsequent ExceptionRange * records when a jump is grown from 2 bytes * to 5 bytes. */ } JumpFixup; #define JUMPFIXUP_INIT_ENTRIES 10 typedef struct JumpFixupArray { JumpFixup *fixup; /* Points to start of jump fixup array. */ Tcl_Size next; /* Index of next free array entry. */ Tcl_Size end; /* Index of last usable entry in array. */ int mallocedArray; /* 1 if array was expanded and fixups points * into the heap, else 0. */ JumpFixup staticFixupSpace[JUMPFIXUP_INIT_ENTRIES]; /* Initial storage for jump fixup array. */ } JumpFixupArray; /* * The structure describing one variable list of a foreach command. Note that * only foreach commands inside procedure bodies are compiled inline so a * ForeachVarList structure always describes local variables. Furthermore, * only scalar variables are supported for inline-compiled foreach loops. */ typedef struct ForeachVarList { Tcl_Size numVars; /* The number of variables in the list. */ Tcl_LVTIndex varIndexes[TCLFLEXARRAY]; /* An array of the indexes ("slot numbers") * for each variable in the procedure's array * of local variables. Only scalar variables * are supported. The actual size of this * field will be large enough to numVars * indexes. THIS MUST BE THE LAST FIELD IN THE * STRUCTURE! */ } ForeachVarList; /* * Structure used to hold information about a foreach command that is needed * during program execution. These structures are stored in CompileEnv and * ByteCode structures as auxiliary data. */ typedef struct ForeachInfo { Tcl_Size numLists; /* The number of both the variable and value * lists of the foreach command. */ Tcl_LVTIndex firstValueTemp;/* Index of the first temp var in a proc frame * used to point to a value list. */ Tcl_LVTIndex loopCtTemp; /* Index of temp var in a proc frame holding * the loop's iteration count. Used to * determine next value list element to assign * each loop var. */ ForeachVarList *varLists[TCLFLEXARRAY]; /* An array of pointers to ForeachVarList * structures describing each var list. The * actual size of this field will be large * enough to numVars indexes. THIS MUST BE THE * LAST FIELD IN THE STRUCTURE! */ } ForeachInfo; /* * Structures used to hold information about a switch command that is needed * during program execution. These structures are stored in CompileEnv and * ByteCode structures as auxiliary data. */ typedef struct JumptableInfo { Tcl_HashTable hashTable; /* Hash that maps strings to signed ints (PC * offsets). */ } JumptableInfo; MODULE_SCOPE const AuxDataType tclJumptableInfoType; #define JUMPTABLEINFO(envPtr, index) \ ((JumptableInfo *) TclFetchAuxData((envPtr), TclGetUInt4AtPtr(index))) static inline JumptableInfo * AllocJumptable(void) { JumptableInfo *jtPtr = (JumptableInfo *) Tcl_Alloc(sizeof(JumptableInfo)); Tcl_InitHashTable(&jtPtr->hashTable, TCL_STRING_KEYS); return jtPtr; } static inline int CreateJumptableEntry( JumptableInfo *jtPtr, const char *keyPtr, Tcl_Size offset) { int isNew; Tcl_HashEntry *hPtr = Tcl_CreateHashEntry(&jtPtr->hashTable, keyPtr, &isNew); if (isNew) { Tcl_SetHashValue(hPtr, INT2PTR(offset)); } return isNew; } #define CreateJumptableEntryToHere(jtPtr, key, baseOffset) \ CreateJumptableEntry((jtPtr), (key), CurrentOffset(envPtr) - (baseOffset)) typedef struct JumptableNumInfo { Tcl_HashTable hashTable; /* Hash that maps Tcl_WideInt to signed ints * (PC offsets). */ } JumptableNumInfo; MODULE_SCOPE const AuxDataType tclJumptableNumericInfoType; #define JUMPTABLENUMINFO(envPtr, index) \ ((JumptableNumInfo *) TclFetchAuxData((envPtr), TclGetUInt4AtPtr(index))) static inline JumptableNumInfo * AllocJumptableNum(void) { JumptableNumInfo *jtnPtr = (JumptableNumInfo *) Tcl_Alloc(sizeof(JumptableNumInfo)); Tcl_InitHashTable(&jtnPtr->hashTable, TCL_ONE_WORD_KEYS); return jtnPtr; } static inline int CreateJumptableNumEntry( JumptableNumInfo *jtnPtr, Tcl_Size key, Tcl_Size offset) { int isNew; Tcl_HashEntry *hPtr = Tcl_CreateHashEntry(&jtnPtr->hashTable, INT2PTR(key), &isNew); if (isNew) { Tcl_SetHashValue(hPtr, INT2PTR(offset)); } return isNew; } #define CreateJumptableNumEntryToHere(jtnPtr, key, baseOffset) \ CreateJumptableNumEntry((jtnPtr), (key), \ CurrentOffset(envPtr) - (baseOffset)) /* * Structure used to hold information about a [dict update] command that is * needed during program execution. These structures are stored in CompileEnv * and ByteCode structures as auxiliary data. */ typedef struct DictUpdateInfo { Tcl_Size length; /* Size of array */ Tcl_Size varIndices[TCLFLEXARRAY]; /* Array of variable indices to manage when * processing the start and end of a [dict * update]. There is really more than one * entry, and the structure is allocated to * take account of this. MUST BE LAST FIELD IN * STRUCTURE. */ } DictUpdateInfo; /* * ClientData type used by the math operator commands. */ typedef struct TclOpCmdClientData { const char *op; /* Do not call it 'operator': C++ reserved */ const char *expected; union OperatorParameter { int numArgs; int identity; } i; } TclOpCmdClientData; /* *---------------------------------------------------------------- * Procedures exported by tclBasic.c to be used within the engine. *---------------------------------------------------------------- */ MODULE_SCOPE Tcl_ObjCmdProc TclNRInterpCoroutine; /* *---------------------------------------------------------------- * Procedures exported by the engine to be used by tclBasic.c *---------------------------------------------------------------- */ MODULE_SCOPE ByteCode * TclCompileObj(Tcl_Interp *interp, Tcl_Obj *objPtr, const CmdFrame *invoker, Tcl_Size word); /* *---------------------------------------------------------------- * Procedures shared among Tcl bytecode compilation and execution modules but * not used outside: *---------------------------------------------------------------- */ MODULE_SCOPE int TclAttemptCompileProc(Tcl_Interp *interp, Tcl_Parse *parsePtr, Tcl_Size depth, Command *cmdPtr, CompileEnv *envPtr); MODULE_SCOPE void TclCleanupStackForBreakContinue(CompileEnv *envPtr, ExceptionAux *auxPtr); MODULE_SCOPE void TclClearFailedCompile(CompileEnv *envPtr, LineInformation *lineInfoPtr); MODULE_SCOPE void TclCompileCmdWord(Tcl_Interp *interp, Tcl_Token *tokenPtr, Tcl_Size count, CompileEnv *envPtr); MODULE_SCOPE void TclCompileExpr(Tcl_Interp *interp, const char *script, Tcl_Size numBytes, CompileEnv *envPtr, int optimize); MODULE_SCOPE void TclCompileExprWords(Tcl_Interp *interp, Tcl_Token *tokenPtr, size_t numWords, CompileEnv *envPtr); MODULE_SCOPE void TclCompileInvocation(Tcl_Interp *interp, Tcl_Token *tokenPtr, Tcl_Obj *cmdObj, size_t numWords, CompileEnv *envPtr); MODULE_SCOPE void TclCompileScript(Tcl_Interp *interp, const char *script, Tcl_Size numBytes, CompileEnv *envPtr); MODULE_SCOPE void TclCompileSyntaxError(Tcl_Interp *interp, CompileEnv *envPtr); MODULE_SCOPE void TclCompileTokens(Tcl_Interp *interp, Tcl_Token *tokenPtr, Tcl_Size count, CompileEnv *envPtr); MODULE_SCOPE void TclCompileVarSubst(Tcl_Interp *interp, Tcl_Token *tokenPtr, CompileEnv *envPtr); MODULE_SCOPE Tcl_AuxDataRef TclCreateAuxData(void *clientData, const AuxDataType *typePtr, CompileEnv *envPtr); MODULE_SCOPE Tcl_ExceptionRange TclCreateExceptRange(ExceptionRangeType type, CompileEnv *envPtr); MODULE_SCOPE ExecEnv * TclCreateExecEnv(Tcl_Interp *interp, size_t size); MODULE_SCOPE Tcl_Obj * TclCreateLiteral(Interp *iPtr, const char *bytes, Tcl_Size length, size_t hash, int *newPtr, Namespace *nsPtr, int flags, LiteralEntry **globalPtrPtr); MODULE_SCOPE void TclDeleteExecEnv(ExecEnv *eePtr); MODULE_SCOPE void TclDeleteLiteralTable(Tcl_Interp *interp, LiteralTable *tablePtr); MODULE_SCOPE void TclEmitForwardJump(CompileEnv *envPtr, TclJumpType jumpType, JumpFixup *jumpFixupPtr); MODULE_SCOPE void TclEmitInvoke(CompileEnv *envPtr, int opcode, ...); MODULE_SCOPE ExceptionRange * TclGetExceptionRangeForPc(unsigned char *pc, int catchOnly, ByteCode *codePtr); MODULE_SCOPE void TclExpandJumpFixupArray(JumpFixupArray *fixupArrayPtr); MODULE_SCOPE int TclNRExecuteByteCode(Tcl_Interp *interp, ByteCode *codePtr); MODULE_SCOPE Tcl_Obj * TclFetchLiteral(CompileEnv *envPtr, Tcl_Size index); MODULE_SCOPE Tcl_LVTIndex TclFindCompiledLocal(const char *name, Tcl_Size nameChars, int create, CompileEnv *envPtr); MODULE_SCOPE void TclFixupForwardJump(CompileEnv *envPtr, JumpFixup *jumpFixupPtr, Tcl_Size jumpDist); MODULE_SCOPE void TclFreeCompileEnv(CompileEnv *envPtr); MODULE_SCOPE void TclFreeJumpFixupArray(JumpFixupArray *fixupArrayPtr); MODULE_SCOPE int TclGetIndexFromToken(Tcl_Token *tokenPtr, size_t before, size_t after, int *indexPtr); MODULE_SCOPE ByteCode * TclInitByteCode(CompileEnv *envPtr); MODULE_SCOPE ByteCode * TclInitByteCodeObj(Tcl_Obj *objPtr, const Tcl_ObjType *typePtr, CompileEnv *envPtr); MODULE_SCOPE void TclInitCompileEnv(Tcl_Interp *interp, CompileEnv *envPtr, const char *string, size_t numBytes, const CmdFrame *invoker, Tcl_Size word); MODULE_SCOPE void TclInitJumpFixupArray(JumpFixupArray *fixupArrayPtr); MODULE_SCOPE void TclInitLiteralTable(LiteralTable *tablePtr); MODULE_SCOPE ExceptionRange *TclGetInnermostExceptionRange(CompileEnv *envPtr, int returnCode, ExceptionAux **auxPtrPtr); MODULE_SCOPE int TclIsEmptyToken(const Tcl_Token *tokenPtr); MODULE_SCOPE void TclAddLoopBreakFixup(CompileEnv *envPtr, ExceptionAux *auxPtr); MODULE_SCOPE void TclAddLoopContinueFixup(CompileEnv *envPtr, ExceptionAux *auxPtr); MODULE_SCOPE void TclFinalizeLoopExceptionRange(CompileEnv *envPtr, Tcl_Size range); #ifdef TCL_COMPILE_STATS MODULE_SCOPE char * TclLiteralStats(LiteralTable *tablePtr); MODULE_SCOPE int TclLog2(long long value); #endif MODULE_SCOPE Tcl_LVTIndex TclLocalScalar(const char *bytes, size_t numBytes, CompileEnv *envPtr); MODULE_SCOPE Tcl_LVTIndex TclLocalScalarFromToken(Tcl_Token *tokenPtr, CompileEnv *envPtr); MODULE_SCOPE void TclOptimizeBytecode(void *envPtr); #ifdef TCL_COMPILE_DEBUG MODULE_SCOPE void TclDebugPrintByteCodeObj(Tcl_Obj *objPtr); #else #define TclDebugPrintByteCodeObj(objPtr) (void)(objPtr) #endif MODULE_SCOPE int TclPrintInstruction(ByteCode *codePtr, const unsigned char *pc); MODULE_SCOPE void TclPrintObject(FILE *outFile, Tcl_Obj *objPtr, Tcl_Size maxChars); MODULE_SCOPE void TclPrintSource(FILE *outFile, const char *string, Tcl_Size maxChars); MODULE_SCOPE void TclPushVarName(Tcl_Interp *interp, Tcl_Token *varTokenPtr, CompileEnv *envPtr, int flags, Tcl_LVTIndex *localIndexPtr, int *isScalarPtr); MODULE_SCOPE void TclPreserveByteCode(ByteCode *codePtr); MODULE_SCOPE int TclRegisterLiteralObj(CompileEnv *envPtr, Tcl_Obj *objPtr, int flags); MODULE_SCOPE void TclReleaseByteCode(ByteCode *codePtr); MODULE_SCOPE void TclReleaseLiteral(Tcl_Interp *interp, Tcl_Obj *objPtr); MODULE_SCOPE void TclInvalidateCmdLiteral(Tcl_Interp *interp, const char *name, Namespace *nsPtr); MODULE_SCOPE Tcl_ObjCmdProc TclSingleOpCmd; MODULE_SCOPE Tcl_ObjCmdProc TclSortingOpCmd; MODULE_SCOPE Tcl_ObjCmdProc TclVariadicOpCmd; MODULE_SCOPE Tcl_ObjCmdProc TclNoIdentOpCmd; #ifdef TCL_COMPILE_DEBUG MODULE_SCOPE void TclVerifyGlobalLiteralTable(Interp *iPtr); MODULE_SCOPE void TclVerifyLocalLiteralTable(CompileEnv *envPtr); #endif MODULE_SCOPE int TclWordKnownAtCompileTime(Tcl_Token *tokenPtr, Tcl_Obj *valuePtr); MODULE_SCOPE void TclLogCommandInfo(Tcl_Interp *interp, const char *script, const char *command, Tcl_Size length, const unsigned char *pc, Tcl_Obj **tosPtr); MODULE_SCOPE Tcl_Obj * TclGetInnerContext(Tcl_Interp *interp, const unsigned char *pc, Tcl_Obj **tosPtr); MODULE_SCOPE Tcl_Obj * TclNewInstNameObj(unsigned char inst); MODULE_SCOPE int TclPushProcCallFrame(void *clientData, Tcl_Interp *interp, Tcl_Size objc, Tcl_Obj *const objv[], int isLambda); /* *---------------------------------------------------------------- * Macros and flag values used by Tcl bytecode compilation and execution * modules inside the Tcl core but not used outside. *---------------------------------------------------------------- */ // Point at which we issue a LIST_CONCAT anyway when doing an expansion sequence #define LIST_CONCAT_THRESHOLD (1 << 15) /* * Simplified form to access AuxData. * * void *TclFetchAuxData(CompileEng *envPtr, Tcl_AuxDataRef index); */ #define TclFetchAuxData(envPtr, index) \ (envPtr)->auxDataArrayPtr[(index)].clientData // Flags for TclRegisterLiteral() enum LiteralFlags { LITERAL_ON_HEAP = 0x01, /* The caller of TclRegisterLiteral already * malloc'd bytes and ownership is passed to * the literal store. */ LITERAL_CMD_NAME = 0x02, /* The literal should not be shared across * namespaces. */ LITERAL_UNSHARED = 0x04 /* The literal should not be shared with any * other usage, even if they're the same string * in the same stack frame. */ }; /* * Adjust the stack requirements. Manually used in cases where the stack * effect cannot be computed from the opcode and its operands, but is still * known at compile time. */ static inline void TclAdjustStackDepth( Tcl_Size delta, CompileEnv *envPtr) { if (delta < 0) { if (envPtr->maxStackDepth < envPtr->currStackDepth) { envPtr->maxStackDepth = envPtr->currStackDepth; } } envPtr->currStackDepth += delta; } #define TclGetStackDepth(envPtr) \ ((envPtr)->currStackDepth) #define TclSetStackDepth(depth, envPtr) \ (envPtr)->currStackDepth = (depth) /* * Verify that the current stack depth is what we think it should be. When * this is wrong, code generation is broken! */ static inline void TclCheckStackDepth( size_t depth, CompileEnv *envPtr) { if (depth != (size_t) envPtr->currStackDepth) { Tcl_Panic("bad stack depth computations: " "is %" TCL_Z_MODIFIER "u, should be %" TCL_Z_MODIFIER "u", (size_t) envPtr->currStackDepth, depth); } } /* * Update the stack requirements based on the instruction definition. It is * called by the functions TclEmitOpCode, TclEmitInst1, TclEmitInst4, et al. * Remark that the very last instruction of a bytecode always reduces the * stack level: INST_DONE or INST_POP, so that the maxStackdepth is always * updated. */ static inline void TclUpdateStackReqs( unsigned char op, Tcl_Size i, CompileEnv *envPtr) { Tcl_Size delta = tclInstructionTable[op].stackEffect; if (delta) { if (delta == INT_MIN) { if (i > INT_MAX || i < INT_MIN+2) { Tcl_Panic("%s: stack effect too big", "TclUpdateStackReqs"); } delta = 1 - i; } TclAdjustStackDepth(delta, envPtr); } /* * Apply stack depth corrections. * These instructions are encoded wrongly because they're cases the * original instruction table design wasn't designed to handle. */ switch (op) { case INST_DICT_GET: case INST_DICT_SET: case INST_DICT_EXISTS: case INST_INVOKE_REPLACE: TclAdjustStackDepth(-1, envPtr); break; case INST_DICT_GET_DEF: TclAdjustStackDepth(-2, envPtr); break; default: /* Do nothing special */ break; } } /* * Function used to update the flag that indicates if we are at the start of a * command, based on whether the opcode is INST_START_COMMAND. */ static inline void TclUpdateAtCmdStart( unsigned char op, CompileEnv *envPtr) { if (envPtr->atCmdStart < 2) { envPtr->atCmdStart = (op == INST_START_CMD ? 1 : 0); } } /* * Function to emit an opcode byte into a CompileEnv's code array. */ static inline void TclEmitOpcode( unsigned char op, CompileEnv *envPtr) { if (envPtr->codeNext == envPtr->codeEnd) { TclExpandCodeArray(envPtr); } *envPtr->codeNext++ = UCHAR(op); TclUpdateAtCmdStart(op, envPtr); TclUpdateStackReqs(op, 0, envPtr); } /* * Functions to emit an integer operand. The macro wrappers allow any C * integral type to be passed. */ static inline void TclEmitInt1Impl( unsigned i, CompileEnv *envPtr) { if (envPtr->codeNext == envPtr->codeEnd) { TclExpandCodeArray(envPtr); } *envPtr->codeNext++ = UCHAR(i); } #define TclEmitInt1(i, envPtr) \ TclEmitInt1Impl((unsigned)(i), (envPtr)) static inline void TclEmitInt4Impl( unsigned i, CompileEnv *envPtr) { if (envPtr->codeNext + 4 > envPtr->codeEnd) { TclExpandCodeArray(envPtr); } *envPtr->codeNext++ = UCHAR(i >> 24); *envPtr->codeNext++ = UCHAR(i >> 16); *envPtr->codeNext++ = UCHAR(i >> 8); *envPtr->codeNext++ = UCHAR(i ); } #define TclEmitInt4(i, envPtr) \ TclEmitInt4Impl((unsigned)(i), (envPtr)) /* * Functions to emit an instruction with signed or unsigned integer operands. * Four byte integers are stored in "big-endian" order with the high order * byte stored at the lowest address. The macro wrappers allow any C * integral type to be passed. */ static inline void TclEmitInstInt1Impl( unsigned char op, unsigned i, CompileEnv *envPtr) { if (envPtr->codeNext + 2 > envPtr->codeEnd) { TclExpandCodeArray(envPtr); } *envPtr->codeNext++ = UCHAR(op); *envPtr->codeNext++ = UCHAR(i); TclUpdateAtCmdStart(op, envPtr); // Emit 1-byte argument TclUpdateStackReqs(op, i, envPtr); } #define TclEmitInstInt1(op, i, envPtr) \ TclEmitInstInt1Impl((op), (unsigned)(i), (envPtr)) static inline void TclEmitInstInt4Impl( unsigned char op, unsigned i, CompileEnv *envPtr) { if (envPtr->codeNext + 5 > envPtr->codeEnd) { TclExpandCodeArray(envPtr); } *envPtr->codeNext++ = UCHAR(op); // Emit 4-byte argument *envPtr->codeNext++ = UCHAR(i >> 24); *envPtr->codeNext++ = UCHAR(i >> 16); *envPtr->codeNext++ = UCHAR(i >> 8); *envPtr->codeNext++ = UCHAR(i ); TclUpdateAtCmdStart(op, envPtr); TclUpdateStackReqs(op, i, envPtr); } #define TclEmitInstInt4(op, i, envPtr) \ TclEmitInstInt4Impl((op), (unsigned)(i), (envPtr)) static inline void TclEmitInstInt14( unsigned char op, unsigned i, unsigned j, CompileEnv *envPtr) { if (envPtr->codeNext + 6 > envPtr->codeEnd) { TclExpandCodeArray(envPtr); } *envPtr->codeNext++ = UCHAR(op); // Emit 1-byte argument *envPtr->codeNext++ = UCHAR(i ); // Emit 4-byte argument *envPtr->codeNext++ = UCHAR(j >> 24); *envPtr->codeNext++ = UCHAR(j >> 16); *envPtr->codeNext++ = UCHAR(j >> 8); *envPtr->codeNext++ = UCHAR(j ); TclUpdateAtCmdStart(op, envPtr); TclUpdateStackReqs(op, i, envPtr); } static inline void TclEmitInstInt41( unsigned char op, unsigned i, unsigned j, CompileEnv *envPtr) { if (envPtr->codeNext + 6 > envPtr->codeEnd) { TclExpandCodeArray(envPtr); } *envPtr->codeNext++ = UCHAR(op); // Emit 4-byte argument *envPtr->codeNext++ = UCHAR(i >> 24); *envPtr->codeNext++ = UCHAR(i >> 16); *envPtr->codeNext++ = UCHAR(i >> 8); *envPtr->codeNext++ = UCHAR(i ); // Emit 1-byte argument *envPtr->codeNext++ = UCHAR(j ); TclUpdateAtCmdStart(op, envPtr); TclUpdateStackReqs(op, i, envPtr); } static inline void TclEmitInstInt44( unsigned char op, unsigned i, unsigned j, CompileEnv *envPtr) { if (envPtr->codeNext + 9 > envPtr->codeEnd) { TclExpandCodeArray(envPtr); } *envPtr->codeNext++ = UCHAR(op); // Emit 4-byte argument *envPtr->codeNext++ = UCHAR(i >> 24); *envPtr->codeNext++ = UCHAR(i >> 16); *envPtr->codeNext++ = UCHAR(i >> 8); *envPtr->codeNext++ = UCHAR(i ); // Emit 4-byte argument *envPtr->codeNext++ = UCHAR(j >> 24); *envPtr->codeNext++ = UCHAR(j >> 16); *envPtr->codeNext++ = UCHAR(j >> 8); *envPtr->codeNext++ = UCHAR(j ); TclUpdateAtCmdStart(op, envPtr); TclUpdateStackReqs(op, i, envPtr); } /* * Function to push a Tcl object onto the Tcl evaluation stack. It emits the * object's four byte array index into the CompileEnv's code array. * This supports a maximum of 2**32 objects in a CompileEnv. */ static inline int TclEmitPush( int objIndex, CompileEnv *envPtr) { TclEmitInstInt4(INST_PUSH, objIndex, envPtr); return objIndex; } /* * Macros to update a (signed or unsigned) integer starting at a pointer. The * two variants depend on the number of bytes. */ static inline void TclStoreInt1AtPtrImpl( unsigned i, unsigned char *p) { p[0] = UCHAR(i); } #define TclStoreInt1AtPtr(i, p) \ TclStoreInt1AtPtrImpl((unsigned)(i), (p)) static inline void TclStoreInt4AtPtrImpl( unsigned i, unsigned char *p) { p[0] = UCHAR(i >> 24); p[1] = UCHAR(i >> 16); p[2] = UCHAR(i >> 8); p[3] = UCHAR(i ); } #define TclStoreInt4AtPtr(i, p) \ TclStoreInt4AtPtrImpl((unsigned)(i), (p)) /* * Macros to update instructions at a particular pc with a new op code and a * (signed or unsigned) int operand. The ANSI C "prototypes" for these macros * are: * * void TclUpdateInstInt1AtPc(unsigned char op, int i, unsigned char *pc); * void TclUpdateInstInt4AtPc(unsigned char op, int i, unsigned char *pc); */ #define TclUpdateInstInt1AtPc(op, i, pc) \ do { \ *(pc) = UCHAR(op); \ TclStoreInt1AtPtr((i), ((pc)+1)); \ } while (0) #define TclUpdateInstInt4AtPc(op, i, pc) \ do { \ *(pc) = UCHAR(op); \ TclStoreInt4AtPtr((i), ((pc)+1)); \ } while (0) /* * Inline func to fix up a forward jump to point to the current code-generation * position in the bytecode being created (the most common case). */ static inline void TclFixupForwardJumpToHere( CompileEnv *envPtr, JumpFixup *fixupPtr) { TclFixupForwardJump(envPtr, fixupPtr, CurrentOffset(envPtr) - (int) fixupPtr->codeOffset); } /* * Macros to get a signed integer (GET_INT{1,2}) or an unsigned int * (GET_UINT{1,2}) from a pointer. There are two variants for each return type * that depend on the number of bytes fetched. The ANSI C "prototypes" for * these macros are: * * int TclGetInt1AtPtr(unsigned char *p); * int TclGetInt4AtPtr(unsigned char *p); * unsigned int TclGetUInt1AtPtr(unsigned char *p); * unsigned int TclGetUInt4AtPtr(unsigned char *p); */ /* * The TclGetInt1AtPtr function is tricky because we want to do sign extension * on the 1-byte value. Unfortunately the "char" type isn't signed on all * platforms so sign-extension doesn't always happen automatically. Sometimes * we can explicitly declare the pointer to be signed, but other times we have * to explicitly sign-extend the value in software. */ static inline int TclGetInt1AtPtr( const unsigned char *p) { #ifndef __CHAR_UNSIGNED__ return (int) *((char *) p); #elif defined(HAVE_SIGNED_CHAR) return (int) *((signed char *) p); #else return (int) ((*((char *) p)) | ((*(p) & 0200) ? (-256) : 0)); #endif } static inline unsigned int TclGetUInt1AtPtr( const unsigned char *p) { return (unsigned) *p; } static inline int TclGetInt4AtPtr( const unsigned char *p) { return (int) ( (TclGetUInt1AtPtr(p) << 24) | (p[1] << 16) | (p[2] << 8) | (p[3] )); } static inline unsigned TclGetUInt4AtPtr( const unsigned char *p) { return (unsigned) ( (p[0] << 24) | (p[1] << 16) | (p[2] << 8) | (p[3] )); } /* * Macros used to compute the minimum and maximum of two values. The ANSI C * "prototypes" for these macros are: * * size_t TclMin(size_t i, size_t j); * size_t TclMax(size_t i, size_t j); */ #define TclMin(i, j) ((((size_t) i) + 1 < ((size_t) j) + 1) ? (i) : (j)) #define TclMax(i, j) ((((size_t) i) + 1 > ((size_t) j) + 1) ? (i) : (j)) /* * Convenience macro for use when compiling tokens to be pushed. The ANSI C * "prototype" for this macro is: * * static void CompileTokens(CompileEnv *envPtr, Tcl_Token *tokenPtr, * Tcl_Interp *interp); */ #define CompileTokens(envPtr, tokenPtr, interp) \ TclCompileTokens((interp), (tokenPtr)+1, (tokenPtr)->numComponents, \ (envPtr)); /* * Convenience macro for use when pushing literals, returning the ID of the * literal. The ANSI C "prototype" for the macro is: * * static int PushLiteral(CompileEnv *envPtr, * const char *string, Tcl_Size length); */ #define PushLiteral(envPtr, string, length) \ TclEmitPush(TclRegisterLiteral((envPtr), (string), (length), 0), (envPtr)) /* * Function to advance to the next token; it is more mnemonic than the address * arithmetic that it replaces. */ static inline Tcl_Token * TokenAfter( Tcl_Token *tokenPtr) { return tokenPtr + (tokenPtr->numComponents + 1); } /* * Note: the exceptDepth is a bit of a misnomer: TEBC only needs the * maximal depth of nested CATCH ranges in order to alloc runtime * memory. These macros should compute precisely that? OTOH, the nesting depth * of LOOP ranges is an interesting datum for debugging purposes, and that is * what we compute now. * * static Tcl_Size ExceptionRangeStarts(CompileEnv *envPtr, Tcl_Size index); * static void ExceptionRangeEnds(CompileEnv *envPtr, Tcl_Size index); * static void ExceptionRangeTarget(CompileEnv *envPtr, Tcl_Size index, LABEL); */ static inline Tcl_Size ExceptionRangeStarts( CompileEnv *envPtr, Tcl_ExceptionRange index) { Tcl_Size offset; envPtr->exceptDepth++; envPtr->maxExceptDepth = TclMax(envPtr->exceptDepth, envPtr->maxExceptDepth); offset = CurrentOffset(envPtr); envPtr->exceptArrayPtr[index].codeOffset = offset; return offset; } static inline void ExceptionRangeEnds( CompileEnv *envPtr, Tcl_ExceptionRange index) { envPtr->exceptDepth--; envPtr->exceptArrayPtr[index].numCodeBytes = CurrentOffset(envPtr) - envPtr->exceptArrayPtr[index].codeOffset; } #define ExceptionRangeTarget(envPtr, index, targetType) \ ((envPtr)->exceptArrayPtr[(index)].targetType = CurrentOffset(envPtr)) /* * Check if there is an LVT for compiled locals */ #define EnvHasLVT(envPtr) \ (envPtr->procPtr || envPtr->iPtr->varFramePtr->localCachePtr) // Stricter than EnvHasLVT; guarantees AnonymousLocal won't fail #define EnvIsProc(envPtr) \ (envPtr->procPtr != NULL) /* * Macros for making it easier to deal with tokens and DStrings. */ #define TclDStringAppendToken(dsPtr, tokenPtr) \ Tcl_DStringAppend((dsPtr), (tokenPtr)->start, (tokenPtr)->size) #define TclRegisterDStringLiteral(envPtr, dsPtr) \ TclRegisterLiteral(envPtr, Tcl_DStringValue(dsPtr), \ Tcl_DStringLength(dsPtr), /*flags*/ 0) #define TclPushDString(envPtr, dsPtr) \ TclEmitPush(TclRegisterDStringLiteral((envPtr), (dsPtr)), (envPtr)) /* * Macro that encapsulates an efficiency trick that avoids a function call for * the simplest of compiles. The ANSI C "prototype" for this macro is: * * static void CompileWord(CompileEnv *envPtr, Tcl_Token *tokenPtr, * Tcl_Interp *interp, Tcl_Size word); */ #define CompileWord(envPtr, tokenPtr, interp, word) \ if ((tokenPtr)->type == TCL_TOKEN_SIMPLE_WORD) { \ PushLiteral((envPtr), (tokenPtr)[1].start, (tokenPtr)[1].size); \ } else { \ SetLineInformation((word)); \ CompileTokens((envPtr), (tokenPtr), (interp)); \ } /* * TIP #280: Remember the per-word line information of the current command. An * index is used instead of a pointer as recursive compilation may reallocate, * i.e. move, the array. This is also the reason to save the nuloc now, it may * change during the course of the function. * * Macros to encapsulate the variable definition and setup. */ #define DefineLineInformation \ LineInformation lineInfo = { \ envPtr->extCmdMapPtr, \ envPtr->extCmdMapPtr->nuloc - 1 \ } #define ExtCmdLocation \ lineInfo.mapPtr->loc[lineInfo.eclIndex] #define SetLineInformation(word) \ do { \ ECL *eclPtr = &ExtCmdLocation; \ envPtr->line = eclPtr->line[(word)]; \ envPtr->clNext = eclPtr->next[(word)]; \ } while (0) #define PushVarNameWord(varTokenPtr,flags,localIndexPtr,isScalarPtr,wordIndex) \ do { \ SetLineInformation(wordIndex); \ TclPushVarName(interp, varTokenPtr, envPtr, flags, \ localIndexPtr, isScalarPtr); \ } while (0) #define ClearFailedCompile(envPtr) \ TclClearFailedCompile((envPtr), &lineInfo) /* * How to get an anonymous local variable (used for holding temporary values * off the stack) or a local simple scalar. */ #define AnonymousLocal(envPtr) \ (TclFindCompiledLocal(NULL, /*nameChars*/ 0, /*create*/ 1, (envPtr))) #define LocalScalar(chars,len,envPtr) \ TclLocalScalar(chars, len, envPtr) #define LocalScalarFromToken(tokenPtr,envPtr) \ TclLocalScalarFromToken(tokenPtr, envPtr) /* * Flags bits used by TclPushVarName. * * TCL_NO_LARGE_INDEX is deprecated entirely; variable indices are always large * in bytecodes we now issue. */ enum PushVarNameFlags { // TCL_NO_LARGE_INDEX = 1, /* Do not return localIndex value > 255 */ TCL_NO_ELEMENT = 2 /* Do not push the array element. */ }; /* * Flags bits used by lreplace4 instruction */ enum Lreplace4Flags { TCL_LREPLACE_END_IS_LAST = 1, /* "end" refers to last element */ TCL_LREPLACE_SINGLE_INDEX = 2, /* Second index absent (pure insert) */ TCL_LREPLACE_NEED_IN_RANGE = 4 /* First index must resolve to real list index */ }; /* Flags bits used by arithSeries instruction */ enum ArithSeqriesFlags { TCL_ARITHSERIES_FROM = 1 << 0, // from is defined (conventionally empty otherwise) TCL_ARITHSERIES_TO = 1 << 1, // to is defined (conventionally empty otherwise) TCL_ARITHSERIES_STEP = 1 << 2, // step is defined (conventionally empty otherwise) TCL_ARITHSERIES_COUNT = 1 << 3, // count is defined (conventionally empty otherwise) }; /* * Helper functions for jump tables that call other internal API bits. */ static inline Tcl_Size RegisterJumptable( JumptableInfo *jtPtr, CompileEnv *envPtr) { return TclCreateAuxData(jtPtr, &tclJumptableInfoType, envPtr); } static inline Tcl_Size RegisterJumptableNum( JumptableNumInfo *jtPtr, CompileEnv *envPtr) { return TclCreateAuxData(jtPtr, &tclJumptableNumericInfoType, envPtr); } /* * The type of "labels" used in FWDLABEL() and BACKLABEL(). Logically, the * result of CurrentOffset(), but specifically not just that. */ typedef Tcl_Size Tcl_BytecodeLabel; /* * Used to indicate that no jump is pending resolution. */ #define NO_PENDING_JUMP ((Tcl_Size) -1) /* * Shorthand macros for instruction issuing. */ // Measure the length of a string literal. #define LENGTH_OF(str) \ ((Tcl_Size) sizeof(str "") - 1) // Issue an instruction without an argument. #define OP(name) TclEmitOpcode(INST_##name, envPtr) // Issue an instruction with a single-byte argument. #define OP1(name,val) TclEmitInstInt1(INST_##name,(val),envPtr) // Issue an instruction with a four-byte argument. #define OP4(name,val) TclEmitInstInt4(INST_##name,(val),envPtr) // Issue an instruction with a single-byte argument and a four-byte argument. #define OP14(name,val1,val2) \ TclEmitInstInt14(INST_##name, (unsigned)(val1), (unsigned)(val2), envPtr) // Issue an instruction with two four-byte arguments. #define OP44(name,val1,val2) \ TclEmitInstInt44(INST_##name, (unsigned)(val1), (unsigned)(val2), envPtr) // Issue an instruction with a foun-byte argument and a single-byte argument. #define OP41(name,val1,val2) \ TclEmitInstInt41(INST_##name, (unsigned)(val1), (unsigned)(val2), envPtr) // Issue a potentially break/continue generating instruction without an argument. #define INVOKE(name) \ TclEmitInvoke(envPtr,INST_##name) // Issue a potentially break/continue generating instruction with a single argument. #define INVOKE4(name,arg1) \ TclEmitInvoke(envPtr,INST_##name,(int)(arg1)) // Issue a potentially break/continue generating instruction with two arguments. #define INVOKE41(name,arg1,arg2) \ TclEmitInvoke(envPtr,INST_##name,(int)(arg1),(int)(arg2)) // Push a string literal. #define PUSH(string) \ PushLiteral((envPtr), (string), LENGTH_OF(string)) // Push a string whose is computed with strlen(). #define PUSH_STRING(strVar) \ PushLiteral(envPtr, (strVar), TCL_AUTO_LENGTH) // Push a string from a TCL_TOKEN_SIMPLE_WORD token. #define PUSH_SIMPLE_TOKEN(tokenPtr) \ PushLiteral(envPtr, (tokenPtr)[1].start, (tokenPtr)[1].size) // Push a string from a TCL_TOKEN_SIMPLE_WORD token where that is a command. #define PUSH_COMMAND_TOKEN(tokenPtr) \ TclEmitPush(TclRegisterLiteral(envPtr, \ (tokenPtr)[1].start, (tokenPtr)[1].size, LITERAL_CMD_NAME), \ envPtr) // Take a reference to a Tcl_Obj and arrange for it to be pushed. #define PUSH_OBJ(objPtr) \ TclEmitPush(TclAddLiteralObj(envPtr, (objPtr), NULL), envPtr) // Take a reference to a Tcl_Obj and arrange for it to be pushed. // Handles extra flags, typically used for command names. #define PUSH_OBJ_FLAGS(objPtr, flags) \ TclEmitPush(TclRegisterLiteralObj(envPtr, (objPtr), (flags)), envPtr) // Push a general token. Needs which index of its command it is. #define PUSH_TOKEN(tokenPtr, index) \ CompileWord(envPtr, (tokenPtr), interp, (index)) // Push a token that is an expression. #define PUSH_EXPR_TOKEN(tokenPtr, index) \ do { \ SetLineInformation(index); \ TclCompileExprWords(interp, (tokenPtr), 1, envPtr); \ } while (0) // Compile the body of a command (e.g., [if], [while]) #define BODY(tokenPtr, index) \ do { \ SetLineInformation((index)); \ TclCompileCmdWord(interp, \ (tokenPtr)+1, (tokenPtr)->numComponents, \ envPtr); \ } while (0) // Set the label to the current address. Typically paired with BACKJUMP. #define BACKLABEL(var) \ (var)=CurrentOffset(envPtr) // Jump (of given type) backwards to the label defined by BACKLABEL. #define BACKJUMP(name, var) \ TclEmitInstInt4(INST_##name,(var)-CurrentOffset(envPtr),envPtr) // Jump (of given type) forwards to the label defined by FWDLABEL. #define FWDJUMP(name, var) \ (var)=CurrentOffset(envPtr);TclEmitInstInt4(INST_##name,0,envPtr) // Set the label to the current address. MUST be paired with FWDJUMP. #define FWDLABEL(var) \ TclStoreInt4AtPtr(CurrentOffset(envPtr)-(var),envPtr->codeStart+(var)+1) // Create an unplaced CATCH exception range. #define MAKE_CATCH_RANGE() \ TclCreateExceptRange(CATCH_EXCEPTION_RANGE, envPtr) // Create an unplaced LOOP exception range. #define MAKE_LOOP_RANGE() \ TclCreateExceptRange(LOOP_EXCEPTION_RANGE, envPtr) #define CATCH_RANGE_VAR(range,var) \ for(int var=(ExceptionRangeStarts(envPtr,(range)), 0); \ !var; \ var=(ExceptionRangeEnds(envPtr,(range)), 1)) // Wrap the given range around a body of code, placing its start and end. #define CATCH_RANGE(range) \ CATCH_RANGE_VAR((range), JOIN(catchRange_, __LINE__)) // Define where caught exceptions in the CATCH range branch to. #define CATCH_TARGET(range) \ ExceptionRangeTarget(envPtr, (range), catchOffset) // Define where caught BREAKs in the LOOP range branch to. #define BREAK_TARGET(range) \ ExceptionRangeTarget(envPtr, (range), breakOffset) // Define where caught CONTINUEs in the LOOP range branch to. #define CONTINUE_TARGET(range) \ ExceptionRangeTarget(envPtr, (range), continueOffset) // Finalize the LOOP exception range, setting the destinations for jumps. #define FINALIZE_LOOP(range) \ TclFinalizeLoopExceptionRange(envPtr, (range)) // Apply a correction to the stack depth. #define STKDELTA(delta) \ TclAdjustStackDepth((delta), envPtr) // Convert a TCL_TOKEN_SIMPLE_WORD token to a Tcl_Obj. #define TokenToObj(tokenPtr) \ Tcl_NewStringObj((tokenPtr)[1].start, (tokenPtr)[1].size) // Test if a token is literally a given string. #define IS_TOKEN_LITERALLY(tokenPtr, str) \ (((tokenPtr)->type == TCL_TOKEN_SIMPLE_WORD) \ && ((tokenPtr)[1].size == LENGTH_OF(str)) \ && strncmp((tokenPtr)[1].start, str, LENGTH_OF(str)) == 0) // Test if a token is a prefix of a given string. #define IS_TOKEN_PREFIX(tokenPtr, minLength, str) \ (((tokenPtr)->type == TCL_TOKEN_SIMPLE_WORD) \ && ((tokenPtr)[1].size >= (Tcl_Size)(minLength)) \ && ((tokenPtr)[1].size <= LENGTH_OF(str)) \ && strncmp((tokenPtr)[1].start, str, (tokenPtr)[1].size) == 0) // Test if a token has a given string as a prefix. #define IS_TOKEN_PREFIXED_BY(tokenPtr, str) \ (((tokenPtr)->type == TCL_TOKEN_SIMPLE_WORD) \ && ((tokenPtr)[1].size > LENGTH_OF(str)) \ && strncmp((tokenPtr)[1].start, str, LENGTH_OF(str)) == 0) /* * DTrace probe macros (NOPs if DTrace support is not enabled). */ /* * Define the following macros to enable debug logging of the DTrace proc, * cmd, and inst probes. Note that this does _not_ require a platform with * DTrace, it simply logs all probe output to /tmp/tclDTraceDebug-[pid].log. * * If the second macro is defined, logging to file starts immediately, * otherwise only after the first call to [tcl::dtrace]. Note that the debug * probe data is always computed, even when it is not logged to file. * * Defining the third macro enables debug logging of inst probes (disabled * by default due to the significant performance impact). */ /* #define TCL_DTRACE_DEBUG 1 #define TCL_DTRACE_DEBUG_LOG_ENABLED 1 #define TCL_DTRACE_DEBUG_INST_PROBES 1 */ #if !(defined(TCL_DTRACE_DEBUG) && defined(__GNUC__)) #ifdef USE_DTRACE #if defined(__GNUC__) && __GNUC__ > 2 /* * Use gcc branch prediction hint to minimize cost of DTrace ENABLED checks. */ #define unlikely(x) (__builtin_expect((x), 0)) #else #define unlikely(x) (x) #endif #define TCL_DTRACE_PROC_ENTRY_ENABLED() unlikely(TCL_PROC_ENTRY_ENABLED()) #define TCL_DTRACE_PROC_RETURN_ENABLED() unlikely(TCL_PROC_RETURN_ENABLED()) #define TCL_DTRACE_PROC_RESULT_ENABLED() unlikely(TCL_PROC_RESULT_ENABLED()) #define TCL_DTRACE_PROC_ARGS_ENABLED() unlikely(TCL_PROC_ARGS_ENABLED()) #define TCL_DTRACE_PROC_INFO_ENABLED() unlikely(TCL_PROC_INFO_ENABLED()) #define TCL_DTRACE_PROC_ENTRY(a0, a1, a2) TCL_PROC_ENTRY(a0, a1, a2) #define TCL_DTRACE_PROC_RETURN(a0, a1) TCL_PROC_RETURN(a0, a1) #define TCL_DTRACE_PROC_RESULT(a0, a1, a2, a3) TCL_PROC_RESULT(a0, a1, a2, a3) #define TCL_DTRACE_PROC_ARGS(a0, a1, a2, a3, a4, a5, a6, a7, a8, a9) \ TCL_PROC_ARGS(a0, a1, a2, a3, a4, a5, a6, a7, a8, a9) #define TCL_DTRACE_PROC_INFO(a0, a1, a2, a3, a4, a5, a6, a7) \ TCL_PROC_INFO(a0, a1, a2, a3, a4, a5, a6, a7) #define TCL_DTRACE_CMD_ENTRY_ENABLED() unlikely(TCL_CMD_ENTRY_ENABLED()) #define TCL_DTRACE_CMD_RETURN_ENABLED() unlikely(TCL_CMD_RETURN_ENABLED()) #define TCL_DTRACE_CMD_RESULT_ENABLED() unlikely(TCL_CMD_RESULT_ENABLED()) #define TCL_DTRACE_CMD_ARGS_ENABLED() unlikely(TCL_CMD_ARGS_ENABLED()) #define TCL_DTRACE_CMD_INFO_ENABLED() unlikely(TCL_CMD_INFO_ENABLED()) #define TCL_DTRACE_CMD_ENTRY(a0, a1, a2) TCL_CMD_ENTRY(a0, a1, a2) #define TCL_DTRACE_CMD_RETURN(a0, a1) TCL_CMD_RETURN(a0, a1) #define TCL_DTRACE_CMD_RESULT(a0, a1, a2, a3) TCL_CMD_RESULT(a0, a1, a2, a3) #define TCL_DTRACE_CMD_ARGS(a0, a1, a2, a3, a4, a5, a6, a7, a8, a9) \ TCL_CMD_ARGS(a0, a1, a2, a3, a4, a5, a6, a7, a8, a9) #define TCL_DTRACE_CMD_INFO(a0, a1, a2, a3, a4, a5, a6, a7) \ TCL_CMD_INFO(a0, a1, a2, a3, a4, a5, a6, a7) #define TCL_DTRACE_INST_START_ENABLED() unlikely(TCL_INST_START_ENABLED()) #define TCL_DTRACE_INST_DONE_ENABLED() unlikely(TCL_INST_DONE_ENABLED()) #define TCL_DTRACE_INST_START(a0, a1, a2) TCL_INST_START(a0, a1, a2) #define TCL_DTRACE_INST_DONE(a0, a1, a2) TCL_INST_DONE(a0, a1, a2) #define TCL_DTRACE_TCL_PROBE_ENABLED() unlikely(TCL_TCL_PROBE_ENABLED()) #define TCL_DTRACE_TCL_PROBE(a0, a1, a2, a3, a4, a5, a6, a7, a8, a9) \ TCL_TCL_PROBE(a0, a1, a2, a3, a4, a5, a6, a7, a8, a9) #define TCL_DTRACE_DEBUG_LOG() MODULE_SCOPE void TclDTraceInfo(Tcl_Obj *info, const char **args, Tcl_Size *argsi); #else /* USE_DTRACE */ #define TCL_DTRACE_PROC_ENTRY_ENABLED() 0 #define TCL_DTRACE_PROC_RETURN_ENABLED() 0 #define TCL_DTRACE_PROC_RESULT_ENABLED() 0 #define TCL_DTRACE_PROC_ARGS_ENABLED() 0 #define TCL_DTRACE_PROC_INFO_ENABLED() 0 #define TCL_DTRACE_PROC_ENTRY(a0, a1, a2) {if (a0) {}} #define TCL_DTRACE_PROC_RETURN(a0, a1) {if (a0) {}} #define TCL_DTRACE_PROC_RESULT(a0, a1, a2, a3) {if (a0) {}; if (a3) {}} #define TCL_DTRACE_PROC_ARGS(a0, a1, a2, a3, a4, a5, a6, a7, a8, a9) {} #define TCL_DTRACE_PROC_INFO(a0, a1, a2, a3, a4, a5, a6, a7) {} #define TCL_DTRACE_CMD_ENTRY_ENABLED() 0 #define TCL_DTRACE_CMD_RETURN_ENABLED() 0 #define TCL_DTRACE_CMD_RESULT_ENABLED() 0 #define TCL_DTRACE_CMD_ARGS_ENABLED() 0 #define TCL_DTRACE_CMD_INFO_ENABLED() 0 #define TCL_DTRACE_CMD_ENTRY(a0, a1, a2) {} #define TCL_DTRACE_CMD_RETURN(a0, a1) {} #define TCL_DTRACE_CMD_RESULT(a0, a1, a2, a3) {} #define TCL_DTRACE_CMD_ARGS(a0, a1, a2, a3, a4, a5, a6, a7, a8, a9) {} #define TCL_DTRACE_CMD_INFO(a0, a1, a2, a3, a4, a5, a6, a7) {} #define TCL_DTRACE_INST_START_ENABLED() 0 #define TCL_DTRACE_INST_DONE_ENABLED() 0 #define TCL_DTRACE_INST_START(a0, a1, a2) {} #define TCL_DTRACE_INST_DONE(a0, a1, a2) {} #define TCL_DTRACE_TCL_PROBE_ENABLED() 0 #define TCL_DTRACE_TCL_PROBE(a0, a1, a2, a3, a4, a5, a6, a7, a8, a9) {} #define TclDTraceInfo(info, args, argsi) {*args = ""; *argsi = 0;} #endif /* USE_DTRACE */ #else /* TCL_DTRACE_DEBUG */ #define USE_DTRACE 1 #if !defined(TCL_DTRACE_DEBUG_LOG_ENABLED) || !(TCL_DTRACE_DEBUG_LOG_ENABLED) #undef TCL_DTRACE_DEBUG_LOG_ENABLED #define TCL_DTRACE_DEBUG_LOG_ENABLED 0 #endif #if !defined(TCL_DTRACE_DEBUG_INST_PROBES) || !(TCL_DTRACE_DEBUG_INST_PROBES) #undef TCL_DTRACE_DEBUG_INST_PROBES #define TCL_DTRACE_DEBUG_INST_PROBES 0 #endif MODULE_SCOPE int tclDTraceDebugEnabled, tclDTraceDebugIndent; MODULE_SCOPE FILE *tclDTraceDebugLog; MODULE_SCOPE void TclDTraceOpenDebugLog(void); MODULE_SCOPE void TclDTraceInfo(Tcl_Obj *info, const char **args, Tcl_Size *argsi); #define TCL_DTRACE_DEBUG_LOG() \ int tclDTraceDebugEnabled = TCL_DTRACE_DEBUG_LOG_ENABLED; \ int tclDTraceDebugIndent = 0; \ FILE *tclDTraceDebugLog = NULL; \ void TclDTraceOpenDebugLog(void) { \ char n[35]; \ snprintf(n, sizeof(n), "/tmp/tclDTraceDebug-%" TCL_Z_MODIFIER "u.log", \ (size_t) getpid()); \ tclDTraceDebugLog = fopen(n, "a"); \ } #define TclDTraceDbgMsg(p, m, ...) \ do { \ if (tclDTraceDebugEnabled) { \ int _l, _t = 0; \ if (!tclDTraceDebugLog) { TclDTraceOpenDebugLog(); } \ fprintf(tclDTraceDebugLog, "%.12s:%.4d:%n", \ strrchr(__FILE__, '/')+1, __LINE__, &_l); _t += _l; \ fprintf(tclDTraceDebugLog, " %.*s():%n", \ (_t < 18 ? 18 - _t : 0) + 18, __func__, &_l); _t += _l; \ fprintf(tclDTraceDebugLog, "%*s" p "%n", \ (_t < 40 ? 40 - _t : 0) + 2 * tclDTraceDebugIndent, \ "", &_l); _t += _l; \ fprintf(tclDTraceDebugLog, "%*s" m "\n", \ (_t < 64 ? 64 - _t : 1), "", ##__VA_ARGS__); \ fflush(tclDTraceDebugLog); \ } \ } while (0) #define TCL_DTRACE_PROC_ENTRY_ENABLED() 1 #define TCL_DTRACE_PROC_RETURN_ENABLED() 1 #define TCL_DTRACE_PROC_RESULT_ENABLED() 1 #define TCL_DTRACE_PROC_ARGS_ENABLED() 1 #define TCL_DTRACE_PROC_INFO_ENABLED() 1 #define TCL_DTRACE_PROC_ENTRY(a0, a1, a2) \ tclDTraceDebugIndent++; \ TclDTraceDbgMsg("-> proc-entry", "%s %" TCL_SIZE_MODIFIER "d %p", a0, a1, a2) #define TCL_DTRACE_PROC_RETURN(a0, a1) \ TclDTraceDbgMsg("<- proc-return", "%s %d", a0, a1); \ tclDTraceDebugIndent-- #define TCL_DTRACE_PROC_RESULT(a0, a1, a2, a3) \ TclDTraceDbgMsg(" | proc-result", "%s %d %s %p", a0, a1, a2, a3) #define TCL_DTRACE_PROC_ARGS(a0, a1, a2, a3, a4, a5, a6, a7, a8, a9) \ TclDTraceDbgMsg(" | proc-args", "%s %s %s %s %s %s %s %s %s %s", a0, \ a1, a2, a3, a4, a5, a6, a7, a8, a9) #define TCL_DTRACE_PROC_INFO(a0, a1, a2, a3, a4, a5, a6, a7) \ TclDTraceDbgMsg(" | proc-info", "%s %s %s %s %d %d %s %s", a0, a1, \ a2, a3, a4, a5, a6, a7) #define TCL_DTRACE_CMD_ENTRY_ENABLED() 1 #define TCL_DTRACE_CMD_RETURN_ENABLED() 1 #define TCL_DTRACE_CMD_RESULT_ENABLED() 1 #define TCL_DTRACE_CMD_ARGS_ENABLED() 1 #define TCL_DTRACE_CMD_INFO_ENABLED() 1 #define TCL_DTRACE_CMD_ENTRY(a0, a1, a2) \ tclDTraceDebugIndent++; \ TclDTraceDbgMsg("-> cmd-entry", "%s %" TCL_SIZE_MODIFIER "d %p", a0, a1, a2) #define TCL_DTRACE_CMD_RETURN(a0, a1) \ TclDTraceDbgMsg("<- cmd-return", "%s %d", a0, a1); \ tclDTraceDebugIndent-- #define TCL_DTRACE_CMD_RESULT(a0, a1, a2, a3) \ TclDTraceDbgMsg(" | cmd-result", "%s %d %s %p", a0, a1, a2, a3) #define TCL_DTRACE_CMD_ARGS(a0, a1, a2, a3, a4, a5, a6, a7, a8, a9) \ TclDTraceDbgMsg(" | cmd-args", "%s %s %s %s %s %s %s %s %s %s", a0, \ a1, a2, a3, a4, a5, a6, a7, a8, a9) #define TCL_DTRACE_CMD_INFO(a0, a1, a2, a3, a4, a5, a6, a7) \ TclDTraceDbgMsg(" | cmd-info", "%s %s %s %s %" TCL_SIZE_MODIFIER "d %" TCL_SIZE_MODIFIER "d %s %s", a0, a1, \ a2, a3, a4, a5, a6, a7) #define TCL_DTRACE_INST_START_ENABLED() TCL_DTRACE_DEBUG_INST_PROBES #define TCL_DTRACE_INST_DONE_ENABLED() TCL_DTRACE_DEBUG_INST_PROBES #define TCL_DTRACE_INST_START(a0, a1, a2) \ TclDTraceDbgMsg(" | inst-start", "%s %d %p", a0, a1, a2) #define TCL_DTRACE_INST_DONE(a0, a1, a2) \ TclDTraceDbgMsg(" | inst-end", "%s %d %p", a0, a1, a2) #define TCL_DTRACE_TCL_PROBE_ENABLED() 1 #define TCL_DTRACE_TCL_PROBE(a0, a1, a2, a3, a4, a5, a6, a7, a8, a9) \ do { \ tclDTraceDebugEnabled = 1; \ TclDTraceDbgMsg(" | tcl-probe", "%s %s %s %s %s %s %s %s %s %s", a0, \ a1, a2, a3, a4, a5, a6, a7, a8, a9); \ } while (0) #endif /* TCL_DTRACE_DEBUG */ #endif /* _TCLCOMPILATION */ /* * Local Variables: * mode: c * c-basic-offset: 4 * fill-column: 78 * End: */