/*
* tclAssembly,c --
*
* Assembler for Tcl bytecodes.
*
* This file contains the procedures that convert Tcl Assembly Language
* (TAL) to a sequence of bytecode instructions for the Tcl execution engine.
*
* Copyright (c) 2010 by Ozgur Dogan Ugurlu.
* Copyright (c) 2010 by Kevin B. Kenny.
*
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
* RCS: @(#) $Id: tclAssembly.c,v 1.1.2.18 2010/12/16 01:40:42 kennykb Exp $
*/
/*-
*- THINGS TO DO:
*- More instructions:
*- done - alternate exit point (affects stack and exception range checking)
*- break and continue - if exception ranges can be sorted out.
*- foreach_start4, foreach_step4
*- returnImm, returnStk
*- expandStart, expandStkTop, invokeExpanded
*- dictFirst, dictNext, dictDone
*- dictUpdateStart, dictUpdateEnd
*- jumpTable testing
*- syntax (?)
*- returnCodeBranch
*/
#include "tclInt.h"
#include "tclCompile.h"
#include "tclOOInt.h"
/* Structure that represents a range of instructions in the bytecode */
typedef struct CodeRange {
int startOffset; /* Start offset in the bytecode array */
int endOffset; /* End offset in the bytecode array */
} CodeRange;
/* State identified for a basic block's catch context */
typedef enum BasicBlockCatchState {
BBCS_UNKNOWN = 0, /* Catch context has not yet been identified */
BBCS_NONE, /* Block is outside of any catch */
BBCS_INCATCH, /* Block is within a catch context */
BBCS_CAUGHT, /* Block is within a catch context and
* may be executed after an exception fires */
} BasicBlockCatchState;
/*
* Structure that defines a basic block - a linear sequence of bytecode
* instructions with no jumps in or out (including not changing the
* state of any exception range).
*/
typedef struct BasicBlock {
int originalStartOffset; /* Instruction offset before JUMP1s
* were substituted with JUMP4's */
int startOffset; /* Instruction offset of the start of
* the block */
int startLine; /* Line number in the input script of the
* instruction at the start of the block */
int jumpOffset; /* Bytecode offset of the 'jump' instruction
* that ends the block, or -1 if there is no
* jump. */
int jumpLine; /* Line number in the input script of the
* 'jump' instruction that ends the block,
* or -1 if there is no jump */
struct BasicBlock* prevPtr; /* Immediate predecessor of this block */
struct BasicBlock* predecessor;
/* Predecessor of this block in the
* spanning tree */
struct BasicBlock * successor1;
/* BasicBlock structure of the following
* block: NULL at the end of the bytecode
* sequence. */
Tcl_Obj * jumpTarget; /* Jump target label if the jump target
* is unresolved */
int initialStackDepth; /* Absolute stack depth on entry */
int minStackDepth; /* Low-water relative stack depth */
int maxStackDepth; /* High-water relative stack depth */
int finalStackDepth; /* Relative stack depth on exit */
enum BasicBlockCatchState catchState;
/* State of the block for 'catch' analysis */
int catchDepth; /* Number of nested catches in which the
* basic block appears */
struct BasicBlock* enclosingCatch;
/* BasicBlock structure of the last
* startCatch executed on a path to this
* block, or NULL if there is no
* enclosing catch */
int foreignExceptionBase; /* Base index of foreign exceptions */
int foreignExceptionCount; /* Count of foreign exceptions */
ExceptionRange* foreignExceptions;
/* ExceptionRange structures for
* exception ranges belonging to embedded
* scripts and expressions in this block */
JumptableInfo* jtPtr; /* Jump table at the end of this basic block */
int flags; /* Boolean flags */
} BasicBlock;
/* Flags that pertain to a basic block */
enum BasicBlockFlags {
BB_VISITED = (1 << 0), /* Block has been visited in the current
* traversal */
BB_FALLTHRU = (1 << 1), /* Control may pass from this block to
* a successor */
BB_JUMP1 = (1 << 2), /* Basic block ends with a 1-byte-offset
* jump and may need expansion */
BB_JUMPTABLE = (1 << 3), /* Basic block ends with a jump table */
BB_BEGINCATCH = (1 << 4), /* Block ends with a 'beginCatch' instruction,
* marking it as the start of a 'catch'
* sequence. The 'jumpTarget' is the exception
* exit from the catch block. */
BB_ENDCATCH = (1 << 5), /* Block ends with an 'endCatch' instruction,
* unwinding the catch from the exception
* stack. */
};
/* Source instruction type recognized by the assembler */
typedef enum TalInstType {
ASSEM_1BYTE, /* Fixed arity, 1-byte instruction */
ASSEM_BEGIN_CATCH,
/* Begin catch: one 4-byte jump offset to be converted
* to appropriate exception ranges */
ASSEM_BOOL, /* One Boolean operand */
ASSEM_BOOL_LVT4,/* One Boolean, one 4-byte LVT ref. */
ASSEM_CONCAT1, /* 1-byte unsigned-integer operand count, must be
* strictly positive, consumes N, produces 1 */
ASSEM_DICT_GET, /* 'dict get' and related - consumes N+1 operands,
* produces 1, N > 0 */
ASSEM_DICT_SET, /* specifies key count and LVT index, consumes N+1 operands,
* produces 1, N > 0 */
ASSEM_DICT_UNSET,
/* specifies key count and LVT index, consumes N operands,
* produces 1, N > 0 */
ASSEM_END_CATCH,/* End catch. No args. Exception range popped from stack
* and stack pointer restored. */
ASSEM_EVAL, /* 'eval' - evaluate a constant script (by compiling it
* in line with the assembly code! I love Tcl!) */
ASSEM_INDEX, /* 4 byte operand, integer or end-integer */
ASSEM_INVOKE, /* 1- or 4-byte operand count, must be strictly positive,
* consumes N, produces 1. */
ASSEM_JUMP, /* Jump instructions */
ASSEM_JUMP4, /* Jump instructions forcing a 4-byte offset */
ASSEM_JUMPTABLE,/* Jumptable (switch -exact) */
ASSEM_LABEL, /* The assembly directive that defines a label */
ASSEM_LINDEX_MULTI,
/* 4-byte operand count, must be strictly positive,
* consumes N, produces 1 */
ASSEM_LIST, /* 4-byte operand count, must be nonnegative, consumses N,
* produces 1 */
ASSEM_LSET_FLAT,/* 4-byte operand count, must be >= 3, consumes N,
* produces 1 */
ASSEM_LVT, /* One operand that references a local variable */
ASSEM_LVT1, /* One 1-byte operand that references a local variable */
ASSEM_LVT1_SINT1,
/* One 1-byte operand that references a local variable,
* one signed-integer 1-byte operand */
ASSEM_LVT4, /* One 4-byte operand that references a local variable */
ASSEM_OVER, /* OVER: 4-byte operand count, consumes N+1, produces N+2 */
ASSEM_PUSH, /* one literal operand */
ASSEM_REGEXP, /* One Boolean operand, but weird mapping to call flags */
ASSEM_REVERSE, /* REVERSE: 4-byte operand count, consumes N, produces N */
ASSEM_SINT1, /* One 1-byte signed-integer operand (INCR_STK_IMM) */
ASSEM_SINT4_LVT4,
/* Signed 4-byte integer operand followed by LVT entry.
* Fixed arity */
} TalInstType;
/* Description of an instruction recognized by the assembler. */
typedef struct TalInstDesc {
const char *name; /* Name of instruction. */
TalInstType instType; /* The type of instruction */
int tclInstCode; /* Instruction code. For instructions having
* 1- and 4-byte variables, tclInstCode is
* ((1byte)<<8) || (4byte) */
int operandsConsumed; /* Number of operands consumed by the
* operation, or INT_MIN if the operation
* is variadic */
int operandsProduced; /* Number of operands produced by the
* operation. If negative, the operation
* has a net stack effect of
* -1-operandsProduced */
} TalInstDesc;
/* Structure that holds the state of the assembler while generating code */
typedef struct AssemblyEnv {
CompileEnv* envPtr; /* Compilation environment being used
* for code generation */
Tcl_Parse* parsePtr; /* Parse of the current line of source */
Tcl_HashTable labelHash; /* Hash table whose keys are labels and
* whose values are 'label' objects storing
* the code offsets of the labels. */
int cmdLine; /* Current line number within the assembly
* code */
int* clNext; /* Invisible continuation line for
* [info frame] */
BasicBlock* head_bb; /* First basic block in the code */
BasicBlock* curr_bb; /* Current basic block */
int maxDepth; /* Maximum stack depth encountered */
int curCatchDepth; /* Current depth of catches */
int maxCatchDepth; /* Maximum depth of catches encountered */
int flags; /* Compilation flags (TCL_EVAL_DIRECT) */
} AssemblyEnv;
/* Static functions defined in this file */
static void AddBasicBlockRangeToErrorInfo(AssemblyEnv*, BasicBlock*);
static BasicBlock * AllocBB(AssemblyEnv*);
static int AssembleOneLine(AssemblyEnv* envPtr);
static void BBAdjustStackDepth(BasicBlock* bbPtr, int consumed, int produced);
static void BBUpdateStackReqs(BasicBlock* bbPtr, int tblind, int count);
static void BBEmitInstInt1(AssemblyEnv* assemEnvPtr, int tblind,
unsigned char opnd, int count);
static void BBEmitInstInt4(AssemblyEnv* assemEnvPtr, int tblind, int opnd,
int count);
static void BBEmitInst1or4(AssemblyEnv* assemEnvPtr, int tblind, int param,
int count);
static void BBEmitOpcode(AssemblyEnv* assemEnvPtr, int tblind, int count);
static int BuildExceptionRanges(AssemblyEnv* assemEnvPtr);
static int CalculateJumpRelocations(AssemblyEnv*, int*);
static int CheckForUnclosedCatches(AssemblyEnv*);
static int CheckForThrowInWrongContext(AssemblyEnv*);
static int CheckNonThrowingBlock(AssemblyEnv*, BasicBlock*);
static int BytecodeMightThrow(unsigned char);
static int CheckJumpTableLabels(AssemblyEnv*, BasicBlock*);
static int CheckNamespaceQualifiers(Tcl_Interp*, const char*, int);
static int CheckNonNegative(Tcl_Interp*, int);
static int CheckOneByte(Tcl_Interp*, int);
static int CheckSignedOneByte(Tcl_Interp*, int);
static int CheckStack(AssemblyEnv*);
static int CheckStrictlyPositive(Tcl_Interp*, int);
static ByteCode * CompileAssembleObj(Tcl_Interp *interp, Tcl_Obj *objPtr);
static void CompileEmbeddedScript(AssemblyEnv*, Tcl_Token*, TalInstDesc*);
static int DefineLabel(AssemblyEnv* envPtr, const char* label);
static void DeleteMirrorJumpTable(JumptableInfo* jtPtr);
static void DupAssembleCodeInternalRep(Tcl_Obj* src, Tcl_Obj* dest);
static void FillInJumpOffsets(AssemblyEnv*);
static int CreateMirrorJumpTable(AssemblyEnv* assemEnvPtr, Tcl_Obj* jumpTable);
static int FindLocalVar(AssemblyEnv* envPtr, Tcl_Token** tokenPtrPtr);
static int FinishAssembly(AssemblyEnv*);
static void FreeAssembleCodeInternalRep(Tcl_Obj *objPtr);
static void FreeAssemblyEnv(AssemblyEnv*);
static int GetBooleanOperand(AssemblyEnv*, Tcl_Token**, int*);
static int GetListIndexOperand(AssemblyEnv*, Tcl_Token**, int*);
static int GetIntegerOperand(AssemblyEnv*, Tcl_Token**, int*);
static int GetNextOperand(AssemblyEnv*, Tcl_Token**, Tcl_Obj**);
static void LookForFreshCatches(BasicBlock*, BasicBlock**);
static void MoveCodeForJumps(AssemblyEnv*, int);
static void MoveExceptionRangesToBasicBlock(AssemblyEnv*, int, int);
static AssemblyEnv* NewAssemblyEnv(CompileEnv*, int);
static int ProcessCatches(AssemblyEnv*);
static int ProcessCatchesInBasicBlock(AssemblyEnv*, BasicBlock*, BasicBlock*,
enum BasicBlockCatchState, int);
static void ResetVisitedBasicBlocks(AssemblyEnv*);
static void ResolveJumpTableTargets(AssemblyEnv*, BasicBlock*);
static void ReportUndefinedLabel(AssemblyEnv*, BasicBlock*, Tcl_Obj*);
static void RestoreEmbeddedExceptionRanges(AssemblyEnv*);
static int StackCheckBasicBlock(AssemblyEnv*, BasicBlock *, BasicBlock *, int);
static BasicBlock* StartBasicBlock(AssemblyEnv*, int fallthrough,
Tcl_Obj* jumpLabel);
/* static int AdvanceIp(const unsigned char *pc); */
static int StackCheckBasicBlock(AssemblyEnv*, BasicBlock *, BasicBlock *, int);
static int StackCheckExit(AssemblyEnv*);
static void StackFreshCatches(AssemblyEnv*, BasicBlock*, int, BasicBlock**,
int*);
static void SyncStackDepth(AssemblyEnv*);
static int TclAssembleCode(CompileEnv* envPtr, const char* code, int codeLen,
int flags);
static void UnstackExpiredCatches(CompileEnv*, BasicBlock*, int,
BasicBlock**, int*);
/* Tcl_ObjType that describes bytecode emitted by the assembler */
static const Tcl_ObjType assembleCodeType = {
"assemblecode",
FreeAssembleCodeInternalRep, /* freeIntRepProc */
DupAssembleCodeInternalRep, /* dupIntRepProc */
NULL, /* updateStringProc */
NULL /* setFromAnyProc */
};
/*
* 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.
*
* Macro to encapsulate the variable definition and setup.
*/
#define DefineLineInformation \
ExtCmdLoc *mapPtr = envPtr->extCmdMapPtr; \
int eclIndex = mapPtr->nuloc - 1
#define SetLineInformation(word) \
envPtr->line = mapPtr->loc[eclIndex].line[(word)]; \
envPtr->clNext = mapPtr->loc[eclIndex].next[(word)]
/*
* Flags bits used by PushVarName.
*/
#define TCL_NO_LARGE_INDEX 1 /* Do not return localIndex value > 255 */
/*
* Source instructions recognized in the Tcl Assembly Language (TAL)
*/
TalInstDesc TalInstructionTable[] = {
/* PUSH must be first, see the code near the end of TclAssembleCode */
{"push", ASSEM_PUSH , (INST_PUSH1<<8
| INST_PUSH4), 0 , 1},
{"add", ASSEM_1BYTE , INST_ADD , 2 , 1},
{"append", ASSEM_LVT, (INST_APPEND_SCALAR1<<8
| INST_APPEND_SCALAR4),1, 1},
{"appendArray", ASSEM_LVT, (INST_APPEND_ARRAY1<<8
| INST_APPEND_ARRAY4), 2, 1},
{"appendArrayStk", ASSEM_1BYTE, INST_APPEND_ARRAY_STK, 3, 1},
{"appendStk", ASSEM_1BYTE, INST_APPEND_STK, 2, 1},
{"beginCatch", ASSEM_BEGIN_CATCH,
INST_BEGIN_CATCH4, 0, 0},
{"bitand", ASSEM_1BYTE , INST_BITAND , 2 , 1},
{"bitnot", ASSEM_1BYTE, INST_BITNOT, 1, 1},
{"bitor", ASSEM_1BYTE , INST_BITOR , 2 , 1},
{"bitxor", ASSEM_1BYTE , INST_BITXOR , 2 , 1},
{"concat", ASSEM_CONCAT1, INST_CONCAT1, INT_MIN,1},
{"dictAppend", ASSEM_LVT4, INST_DICT_APPEND, 2, 1},
{"dictGet", ASSEM_DICT_GET, INST_DICT_GET, INT_MIN,1},
{"dictIncrImm", ASSEM_SINT4_LVT4,
INST_DICT_INCR_IMM, 1, 1},
{"dictLappend", ASSEM_LVT4, INST_DICT_LAPPEND, 2, 1},
{"dictSet", ASSEM_DICT_SET, INST_DICT_SET, INT_MIN,1},
{"dictUnset", ASSEM_DICT_UNSET,
INST_DICT_UNSET, INT_MIN,1},
{"div", ASSEM_1BYTE, INST_DIV, 2, 1},
{"dup", ASSEM_1BYTE , INST_DUP , 1 , 2},
{"endCatch", ASSEM_END_CATCH,INST_END_CATCH, 0, 0},
{"eq", ASSEM_1BYTE , INST_EQ , 2 , 1},
{"eval", ASSEM_EVAL, INST_EVAL_STK, 1, 1},
{"evalStk", ASSEM_1BYTE, INST_EVAL_STK, 1, 1},
{"exist", ASSEM_LVT4, INST_EXIST_SCALAR, 0, 1},
{"existArray", ASSEM_LVT4, INST_EXIST_ARRAY, 1, 1},
{"existArrayStk", ASSEM_1BYTE, INST_EXIST_ARRAY_STK, 2, 1},
{"existStk", ASSEM_1BYTE, INST_EXIST_STK, 1, 1},
{"expon", ASSEM_1BYTE, INST_EXPON, 2, 1},
{"expr", ASSEM_EVAL, INST_EXPR_STK, 1, 1},
{"exprStk", ASSEM_1BYTE, INST_EXPR_STK, 1, 1},
{"ge", ASSEM_1BYTE , INST_GE , 2 , 1},
{"gt", ASSEM_1BYTE , INST_GT , 2 , 1},
{"incr", ASSEM_LVT1, INST_INCR_SCALAR1, 1, 1},
{"incrArray", ASSEM_LVT1, INST_INCR_ARRAY1, 2, 1},
{"incrArrayImm", ASSEM_LVT1_SINT1,
INST_INCR_ARRAY1_IMM, 1, 1},
{"incrArrayStk", ASSEM_1BYTE, INST_INCR_ARRAY_STK, 3, 1},
{"incrArrayStkImm", ASSEM_SINT1, INST_INCR_ARRAY_STK_IMM,2, 1},
{"incrImm", ASSEM_LVT1_SINT1,
INST_INCR_SCALAR1_IMM, 0, 1},
{"incrStk", ASSEM_1BYTE, INST_INCR_SCALAR_STK, 2, 1},
{"incrStkImm", ASSEM_SINT1, INST_INCR_SCALAR_STK_IMM,
1, 1},
{"invokeStk", ASSEM_INVOKE, (INST_INVOKE_STK1 << 8
| INST_INVOKE_STK4), INT_MIN,1},
{"jump", ASSEM_JUMP, INST_JUMP1, 0, 0},
{"jump4", ASSEM_JUMP4, INST_JUMP4, 0, 0},
{"jumpFalse", ASSEM_JUMP, INST_JUMP_FALSE1, 1, 0},
{"jumpFalse4", ASSEM_JUMP4, INST_JUMP_FALSE4, 1, 0},
{"jumpTable", ASSEM_JUMPTABLE,INST_JUMP_TABLE, 1, 0},
{"jumpTrue", ASSEM_JUMP, INST_JUMP_TRUE1, 1, 0},
{"jumpTrue4", ASSEM_JUMP4, INST_JUMP_TRUE4, 1, 0},
{"label", ASSEM_LABEL, 0, 0, 0},
{"land", ASSEM_1BYTE , INST_LAND , 2 , 1},
{"lappend", ASSEM_LVT, (INST_LAPPEND_SCALAR1<<8
| INST_LAPPEND_SCALAR4),
1, 1},
{"lappendArray", ASSEM_LVT, (INST_LAPPEND_ARRAY1<<8
| INST_LAPPEND_ARRAY4),2, 1},
{"lappendArrayStk", ASSEM_1BYTE, INST_LAPPEND_ARRAY_STK, 3, 1},
{"lappendStk", ASSEM_1BYTE, INST_LAPPEND_STK, 2, 1},
{"le", ASSEM_1BYTE , INST_LE , 2 , 1},
{"lindexMulti", ASSEM_LINDEX_MULTI,
INST_LIST_INDEX_MULTI, INT_MIN,1},
{"list", ASSEM_LIST, INST_LIST, INT_MIN,1},
{"listIn", ASSEM_1BYTE, INST_LIST_IN, 2, 1},
{"listIndex", ASSEM_1BYTE, INST_LIST_INDEX, 2, 1},
{"listIndexImm", ASSEM_INDEX, INST_LIST_INDEX_IMM, 1, 1},
{"listLength", ASSEM_1BYTE, INST_LIST_LENGTH, 1, 1},
{"listNotIn", ASSEM_1BYTE, INST_LIST_NOT_IN, 2, 1},
{"load", ASSEM_LVT, (INST_LOAD_SCALAR1 << 8
| INST_LOAD_SCALAR4), 0, 1},
{"loadArray", ASSEM_LVT, (INST_LOAD_ARRAY1<<8
| INST_LOAD_ARRAY4), 1, 1},
{"loadArrayStk", ASSEM_1BYTE, INST_LOAD_ARRAY_STK, 2, 1},
{"loadStk", ASSEM_1BYTE, INST_LOAD_SCALAR_STK, 1, 1},
{"lor", ASSEM_1BYTE , INST_LOR , 2 , 1},
{"lsetFlat", ASSEM_LSET_FLAT,INST_LSET_FLAT, INT_MIN,1},
{"lsetList", ASSEM_1BYTE, INST_LSET_LIST, 3, 1},
{"lshift", ASSEM_1BYTE , INST_LSHIFT , 2 , 1},
{"lt", ASSEM_1BYTE , INST_LT , 2 , 1},
{"mod", ASSEM_1BYTE, INST_MOD, 2, 1},
{"mult", ASSEM_1BYTE , INST_MULT , 2 , 1},
{"neq", ASSEM_1BYTE , INST_NEQ , 2 , 1},
{"nop", ASSEM_1BYTE, INST_NOP, 0, 0},
{"not", ASSEM_1BYTE, INST_LNOT, 1, 1},
{"nsupvar", ASSEM_LVT4, INST_NSUPVAR, 2, 1},
{"over", ASSEM_OVER, INST_OVER, INT_MIN,-1-1},
{"pop", ASSEM_1BYTE , INST_POP , 1 , 0},
{"pushReturnCode", ASSEM_1BYTE, INST_PUSH_RETURN_CODE, 0, 1},
{"pushReturnOpts", ASSEM_1BYTE, INST_PUSH_RETURN_OPTIONS,
0, 1},
{"pushResult", ASSEM_1BYTE, INST_PUSH_RESULT, 0, 1},
{"regexp", ASSEM_REGEXP, INST_REGEXP, 2, 1},
{"reverse", ASSEM_REVERSE, INST_REVERSE, INT_MIN,-1-0},
{"rshift", ASSEM_1BYTE , INST_RSHIFT , 2 , 1},
{"store", ASSEM_LVT, (INST_STORE_SCALAR1<<8
| INST_STORE_SCALAR4), 1, 1},
{"storeArray", ASSEM_LVT, (INST_STORE_ARRAY1<<8
| INST_STORE_ARRAY4), 2, 1},
{"storeArrayStk", ASSEM_1BYTE, INST_STORE_ARRAY_STK, 3, 1},
{"storeStk", ASSEM_1BYTE, INST_STORE_SCALAR_STK, 2, 1},
{"strcmp", ASSEM_1BYTE, INST_STR_CMP, 2, 1},
{"streq", ASSEM_1BYTE, INST_STR_EQ, 2, 1},
{"strindex", ASSEM_1BYTE, INST_STR_INDEX, 2, 1},
{"strlen", ASSEM_1BYTE, INST_STR_LEN, 1, 1},
{"strmatch", ASSEM_BOOL, INST_STR_MATCH, 2, 1},
{"strneq", ASSEM_1BYTE, INST_STR_NEQ, 2, 1},
{"sub", ASSEM_1BYTE , INST_SUB , 2 , 1},
{"tryCvtToNumeric", ASSEM_1BYTE, INST_TRY_CVT_TO_NUMERIC,1, 1},
{"uminus", ASSEM_1BYTE, INST_UMINUS, 1, 1},
{"unset", ASSEM_BOOL_LVT4,INST_UNSET_SCALAR, 0, 0},
{"unsetArray", ASSEM_BOOL_LVT4,INST_UNSET_ARRAY, 1, 0},
{"unsetArrayStk", ASSEM_BOOL, INST_UNSET_ARRAY_STK, 2, 0},
{"unsetStk", ASSEM_BOOL, INST_UNSET_STK, 1, 0},
{"uplus", ASSEM_1BYTE, INST_UPLUS, 1, 1},
{"upvar", ASSEM_LVT4, INST_UPVAR, 2, 1},
{"variable", ASSEM_LVT4, INST_VARIABLE, 1, 0},
{NULL, 0, 0, 0, 0}
};
/*
* List of instructions that cannot throw an exception under any circumstances.
* These instructions are the ones that are permissible after an exception
* is caught but before the corresponding exception range is popped from
* the stack.
* The instructions must be in ascending order by numeric operation code.
*/
static unsigned char NonThrowingByteCodes[] = {
INST_PUSH1, INST_PUSH4, INST_POP, INST_DUP, /* 1-4 */
INST_JUMP1, INST_JUMP4, /* 34-35 */
INST_END_CATCH, INST_PUSH_RESULT, INST_PUSH_RETURN_CODE, /* 70-72 */
INST_OVER, /* 95 */
INST_PUSH_RETURN_OPTIONS, /* 108 */
INST_REVERSE, /* 126 */
INST_NOP /* 132 */
};
/*
*-----------------------------------------------------------------------------
*
* BBAdjustStackDepth --
*
* When an opcode is emitted, adjusts the stack information in the
* basic block to reflect the number of operands produced and consumed.
*
* Results:
* None.
*
* Side effects:
* Updates minimum, maximum and final stack requirements in the
* basic block.
*
*-----------------------------------------------------------------------------
*/
static void
BBAdjustStackDepth(BasicBlock* bbPtr,
/* Structure describing the basic block */
int consumed,
/* Count of operands consumed by the
* operation */
int produced)
/* Count of operands produced by the
* operation */
{
int depth = bbPtr->finalStackDepth;
depth -= consumed;
if (depth < bbPtr->minStackDepth) {
bbPtr->minStackDepth = depth;
}
depth += produced;
if (depth > bbPtr->maxStackDepth) {
bbPtr->maxStackDepth = depth;
}
bbPtr->finalStackDepth = depth;
}
/*
*-----------------------------------------------------------------------------
*
* BBUpdateStackReqs --
*
* Updates the stack requirements of a basic block, given the opcode
* being emitted and an operand count.
*
* Results:
* None.
*
* Side effects:
* Updates min, max and final stack requirements in the basic block.
*
* Notes:
* This function must not be called for instructions such as REVERSE
* and OVER that are variadic but do not consume all their operands.
* Instead, BBAdjustStackDepth should be called directly.
*
* count should be provided only for variadic operations. For
* operations with known arity, count should be 0.
*
*-----------------------------------------------------------------------------
*/
static void
BBUpdateStackReqs(BasicBlock* bbPtr,
/* Structure describing the basic block */
int tblind, /* Index in TalInstructionTable of the
* operation being assembled */
int count) /* Count of operands for variadic insts */
{
int consumed = TalInstructionTable[tblind].operandsConsumed;
int produced = TalInstructionTable[tblind].operandsProduced;
if (consumed == INT_MIN) {
/* The instruction is variadic; it consumes 'count' operands. */
consumed = count;
}
if (produced < 0) {
/* The instruction leaves some of its variadic operands on the stack,
* with net stack effect of '-1-produced' */
produced = consumed - produced - 1;
}
BBAdjustStackDepth(bbPtr, consumed, produced);
}
/*
*-----------------------------------------------------------------------------
*
* BBEmitOpcode, BBEmitInstInt1, BBEmitInstInt4 --
*
* Emit the opcode part of an instruction, or the entirety of an
* instruction with a 1- or 4-byte operand, and adjust stack requirements.
*
* Results:
* None.
*
* Side effects:
* Stores instruction and operand in the operand stream, and
* adjusts the stack.
*
*-----------------------------------------------------------------------------
*/
static void
BBEmitOpcode(AssemblyEnv* assemEnvPtr,
/* Assembly environment */
int tblind, /* Table index in TalInstructionTable of op */
int count) /* Operand count for variadic ops */
{
CompileEnv* envPtr = assemEnvPtr->envPtr;
/* Compilation environment */
BasicBlock* bbPtr = assemEnvPtr->curr_bb;
/* Current basic block */
int op = TalInstructionTable[tblind].tclInstCode & 0xff;
/* If this is the first instruction in a basic block, record its
* line number. */
if (bbPtr->startOffset == envPtr->codeNext - envPtr->codeStart) {
bbPtr->startLine = assemEnvPtr->cmdLine;
}
TclEmitInt1(op, envPtr);
envPtr->atCmdStart = ((op) == INST_START_CMD);
BBUpdateStackReqs(bbPtr, tblind, count);
}
static void
BBEmitInstInt1(AssemblyEnv* assemEnvPtr,
/* Assembly environment */
int tblind, /* Index in TalInstructionTable of op */
unsigned char opnd,
/* 1-byte operand */
int count) /* Operand count for variadic ops */
{
BBEmitOpcode(assemEnvPtr, tblind, count);
TclEmitInt1(opnd, assemEnvPtr->envPtr);
}
static void
BBEmitInstInt4(AssemblyEnv* assemEnvPtr,
/* Assembly environment */
int tblind, /* Index in TalInstructionTable of op */
int opnd, /* 4-byte operand */
int count) /* Operand count for variadic ops */
{
BBEmitOpcode(assemEnvPtr, tblind, count);
TclEmitInt4(opnd, assemEnvPtr->envPtr);
}
/*
*-----------------------------------------------------------------------------
*
* BBEmitInst1or4 --
*
* Emits a 1- or 4-byte operation according to the magnitude of the
* operand
*
*-----------------------------------------------------------------------------
*/
static void
BBEmitInst1or4(AssemblyEnv* assemEnvPtr,
/* Assembly environment */
int tblind, /* Index in TalInstructionTable of op */
int param, /* Variable-length parameter */
int count) /* Arity if variadic */
{
CompileEnv* envPtr = assemEnvPtr->envPtr;
/* Compilation environment */
BasicBlock* bbPtr = assemEnvPtr->curr_bb;
/* Current basic block */
int op = TalInstructionTable[tblind].tclInstCode;
if (param <= 0xff) {
op >>= 8;
} else {
op &= 0xff;
}
TclEmitInt1(op, envPtr);
if (param <= 0xff) {
TclEmitInt1(param, envPtr);
} else {
TclEmitInt4(param, envPtr);
}
envPtr->atCmdStart = ((op) == INST_START_CMD);
BBUpdateStackReqs(bbPtr, tblind, count);
}
/*
*-----------------------------------------------------------------------------
*
* Tcl_AssembleObjCmd, TclNRAssembleObjCmd --
*
* Direct evaluation path for tcl::unsupported::assemble
*
* Results:
* Returns a standard Tcl result.
*
* Side effects:
* Assembles the code in objv[1], and executes it, so side effects
* include whatever the code does.
*
*-----------------------------------------------------------------------------
*/
int
Tcl_AssembleObjCmd(
ClientData dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
/*
* Boilerplate - make sure that there is an NRE trampoline on the
* C stack because there needs to be one in place to execute bytecode.
*/
return Tcl_NRCallObjProc(interp, TclNRAssembleObjCmd, dummy, objc, objv);
}
int
TclNRAssembleObjCmd(
ClientData dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
ByteCode *codePtr; /* Pointer to the bytecode to execute */
Tcl_Obj* backtrace; /* Object where extra error information
* is constructed. */
/* Check args */
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "bytecodeList");
return TCL_ERROR;
}
/* Assemble the source to bytecode */
codePtr = CompileAssembleObj(interp, objv[1]);
/* On failure, report error line */
if (codePtr == NULL) {
Tcl_AddErrorInfo(interp, "\n (\"");
Tcl_AddErrorInfo(interp, Tcl_GetString(objv[0]));
Tcl_AddErrorInfo(interp, "\" body, line ");
backtrace = Tcl_NewIntObj(Tcl_GetErrorLine(interp));
Tcl_IncrRefCount(backtrace);
Tcl_AddErrorInfo(interp, Tcl_GetString(backtrace));
Tcl_DecrRefCount(backtrace);
Tcl_AddErrorInfo(interp, ")");
return TCL_ERROR;
}
/* Use NRE to evaluate the bytecode from the trampoline */
/*
Tcl_NRAddCallback(interp, NRCallTEBC, INT2PTR(TCL_NR_BC_TYPE), codePtr,
NULL, NULL);
return TCL_OK;
*/
return TclNRExecuteByteCode(interp, codePtr);
}
/*
*-----------------------------------------------------------------------------
*
* CompileAssembleObj --
*
* Sets up and assembles Tcl bytecode for the direct-execution path
* in the Tcl bytecode assembler.
*
* Results:
* Returns a pointer to the assembled code. Returns NULL if the
* assembly fails for any reason, with an appropriate error message
* in the interpreter.
*
*-----------------------------------------------------------------------------
*/
static ByteCode *
CompileAssembleObj(
Tcl_Interp *interp, /* Tcl interpreter */
Tcl_Obj *objPtr) /* Source code to assemble */
{
Interp *iPtr = (Interp *) interp;
/* Internals of the interpreter */
CompileEnv compEnv; /* Compilation environment structure */
register ByteCode *codePtr = NULL;
/* Bytecode resulting from the assembly */
Namespace* namespacePtr; /* Namespace in which variable and
* command names in the bytecode resolve */
int status; /* Status return from Tcl_AssembleCode */
const char* source; /* String representation of the
* source code */
int sourceLen; /* Length of the source code in bytes */
/*
* Get the expression ByteCode from the object. If it exists, make sure it
* is valid in the current context.
*/
if (objPtr->typePtr == &assembleCodeType) {
namespacePtr = iPtr->varFramePtr->nsPtr;
codePtr = (ByteCode *) objPtr->internalRep.otherValuePtr;
if (((Interp *) *codePtr->interpHandle != iPtr)
|| (codePtr->compileEpoch != iPtr->compileEpoch)
|| (codePtr->nsPtr != namespacePtr)
|| (codePtr->nsEpoch != namespacePtr->resolverEpoch)
|| (codePtr->localCachePtr != iPtr->varFramePtr->localCachePtr)) {
FreeAssembleCodeInternalRep(objPtr);
}
}
if (objPtr->typePtr != &assembleCodeType) {
/* Set up the compilation environment, and assemble the code */
source = TclGetStringFromObj(objPtr, &sourceLen);
TclInitCompileEnv(interp, &compEnv, source, sourceLen, NULL, 0);
status = TclAssembleCode(&compEnv, source, sourceLen, TCL_EVAL_DIRECT);
if (status != TCL_OK) {
/* Assembly failed. Clean up and report the error */
TclFreeCompileEnv(&compEnv);
return NULL;
}
/*
* Add a "done" instruction as the last instruction and change the
* object into a ByteCode object. Ownership of the literal objects and
* aux data items is given to the ByteCode object.
*/
TclEmitOpcode(INST_DONE, &compEnv);
TclInitByteCodeObj(objPtr, &compEnv);
objPtr->typePtr = &assembleCodeType;
TclFreeCompileEnv(&compEnv);
/*
* Record the local variable context to which the bytecode pertains
*/
codePtr = (ByteCode *) objPtr->internalRep.otherValuePtr;
if (iPtr->varFramePtr->localCachePtr) {
codePtr->localCachePtr = iPtr->varFramePtr->localCachePtr;
codePtr->localCachePtr->refCount++;
}
/* Report on what the assembler did. */
#ifdef TCL_COMPILE_DEBUG
if (tclTraceCompile >= 2) {
TclPrintByteCodeObj(interp, objPtr);
fflush(stdout);
}
#endif /* TCL_COMPILE_DEBUG */
}
return codePtr;
}
/*
*-----------------------------------------------------------------------------
*
* TclCompileAssembleCmd --
*
* Compilation procedure for the '::tcl::unsupported::assemble' command.
*
* Results:
* Returns a standard Tcl result.
*
* Side effects:
* Puts the result of assembling the code into the bytecode stream
* in 'compileEnv'.
*
* This procedure makes sure that the command has a single arg, which is
* constant. If that condition is met, the procedure calls TclAssembleCode
* to produce bytecode for the given assembly code, and returns any error
* resulting from the assembly.
*
*-----------------------------------------------------------------------------
*/
int TclCompileAssembleCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
Command *cmdPtr, /* Points to defintion of command being
* compiled. */
CompileEnv *envPtr) /* Holds resulting instructions. */
{
Tcl_Token *tokenPtr; /* Token in the input script */
int status; /* Status return from assembling the code */
/* Make sure that the command has a single arg */
if (parsePtr->numWords != 2) {
return TCL_ERROR;
}
/* Make sure that the arg is a simple word */
tokenPtr = TokenAfter(parsePtr->tokenPtr);
if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
return TCL_ERROR;
}
/* Compile the code and return any error from the compilation */
status = TclAssembleCode(envPtr, tokenPtr[1].start, tokenPtr[1].size, 0);
return status;
}
/*
*-----------------------------------------------------------------------------
*
* TclAssembleCode --
*
* Take a list of instructions in a Tcl_Obj, and assemble them to
* Tcl bytecodes
*
* Results:
* Returns TCL_OK on success, TCL_ERROR on failure.
* If 'flags' includes TCL_EVAL_DIRECT, places an error message
* in the interpreter result.
*
* Side effects:
* Adds byte codes to the compile environment, and updates the
* environment's stack depth.
*
*-----------------------------------------------------------------------------
*/
static int
TclAssembleCode(CompileEnv *envPtr,
/* Compilation environment that is to
* receive the generated bytecode */
const char* codePtr,
/* Assembly-language code to be processed */
int codeLen, /* Length of the code */
int flags) /* OR'ed combination of flags */
{
Tcl_Interp* interp = (Tcl_Interp*) envPtr->iPtr;
/* Tcl interpreter */
/*
* Walk through the assembly script using the Tcl parser.
* Each 'command' will be an instruction or assembly directive.
*/
const char* instPtr = codePtr;
/* Where to start looking for a line of code */
int instLen; /* Length in bytes of the current line of
* code */
const char* nextPtr; /* Pointer to the end of the line of code */
int bytesLeft = codeLen; /* Number of bytes of source code remaining
* to be parsed */
int status; /* Tcl status return */
AssemblyEnv* assemEnvPtr = NewAssemblyEnv(envPtr, flags);
Tcl_Parse* parsePtr = assemEnvPtr->parsePtr;
do {
/* Parse out one command line from the assembly script */
status = Tcl_ParseCommand(interp, instPtr, bytesLeft, 0, parsePtr);
instLen = parsePtr->commandSize;
if (parsePtr->term == parsePtr->commandStart + instLen - 1) {
--instLen;
}
/* Report errors in the parse */
if (status != TCL_OK) {
if (flags & TCL_EVAL_DIRECT) {
Tcl_LogCommandInfo(interp, codePtr, parsePtr->commandStart,
instLen);
}
FreeAssemblyEnv(assemEnvPtr);
return TCL_ERROR;
}
/* Advance the pointers around any leading commentary */
TclAdvanceLines(&assemEnvPtr->cmdLine, instPtr, parsePtr->commandStart);
TclAdvanceContinuations(&assemEnvPtr->cmdLine, &assemEnvPtr->clNext,
parsePtr->commandStart - envPtr->source);
/* Process the line of code */
if (parsePtr->numWords > 0) {
/* If tracing, show each line assembled as it happens */
#ifdef TCL_COMPILE_DEBUG
if ((tclTraceCompile >= 2) && (envPtr->procPtr == NULL)) {
printf(" %4d Assembling: ",
envPtr->codeNext - envPtr->codeStart);
TclPrintSource(stdout, parsePtr->commandStart,
TclMin(instLen, 55));
printf("\n");
}
#endif
if (AssembleOneLine(assemEnvPtr) != TCL_OK) {
if (flags & TCL_EVAL_DIRECT) {
Tcl_LogCommandInfo(interp, codePtr, parsePtr->commandStart,
instLen);
}
Tcl_FreeParse(parsePtr);
FreeAssemblyEnv(assemEnvPtr);
return TCL_ERROR;
}
}
/* Advance to the next line of code */
nextPtr = parsePtr->commandStart + parsePtr->commandSize;
bytesLeft -= (nextPtr - instPtr);
instPtr = nextPtr;
TclAdvanceLines(&assemEnvPtr->cmdLine, parsePtr->commandStart, instPtr);
TclAdvanceContinuations(&assemEnvPtr->cmdLine, &assemEnvPtr->clNext,
instPtr - envPtr->source);
Tcl_FreeParse(parsePtr);
} while (bytesLeft > 0);
/* Done with parsing the code */
status = FinishAssembly(assemEnvPtr);
FreeAssemblyEnv(assemEnvPtr);
return status;
}
/*
*-----------------------------------------------------------------------------
*
* NewAssemblyEnv --
*
* Creates an environment for the assembler to run in.
*
* Results:
* Allocates, initialises and returns an assembler environment
*
*-----------------------------------------------------------------------------
*/
static AssemblyEnv*
NewAssemblyEnv(CompileEnv* envPtr,
/* Compilation environment being used
* for code generation*/
int flags) /* Compilation flags (TCL_EVAL_DIRECT) */
{
Tcl_Interp* interp = (Tcl_Interp*) envPtr->iPtr;
/* Tcl interpreter */
AssemblyEnv* assemEnvPtr = TclStackAlloc(interp, sizeof(AssemblyEnv));
/* Assembler environment under construction */
Tcl_Parse* parsePtr = TclStackAlloc(interp, sizeof(Tcl_Parse));
/* Parse of one line of assembly code */
assemEnvPtr->envPtr = envPtr;
assemEnvPtr->parsePtr = parsePtr;
assemEnvPtr->cmdLine = envPtr->line;
assemEnvPtr->clNext = envPtr->clNext;
/* Make the hashtables that store symbol resolution */
Tcl_InitHashTable(&assemEnvPtr->labelHash, TCL_STRING_KEYS);
/* Start the first basic block */
assemEnvPtr->curr_bb = NULL;
assemEnvPtr->head_bb = AllocBB(assemEnvPtr);
assemEnvPtr->curr_bb = assemEnvPtr->head_bb;
assemEnvPtr->head_bb->startLine = 1;
/* Stash compilation flags */
assemEnvPtr->flags = flags;
return assemEnvPtr;
}
/*
*-----------------------------------------------------------------------------
*
* FreeAssemblyEnv --
*
* Cleans up the assembler environment when assembly is complete.
*
*-----------------------------------------------------------------------------
*/
static void
FreeAssemblyEnv(AssemblyEnv* assemEnvPtr)
/* Environment to free */
{
CompileEnv* envPtr = assemEnvPtr->envPtr;
/* Compilation environment being used
* for code generation */
Tcl_Interp* interp = (Tcl_Interp*) envPtr->iPtr;
/* Tcl interpreter */
BasicBlock* thisBB; /* Pointer to a basic block being deleted */
BasicBlock* nextBB; /* Pointer to a deleted basic block's
* successor */
Tcl_HashEntry* hashEntry;
Tcl_HashSearch hashSearch;
/* Free all the basic block structures */
for (thisBB = assemEnvPtr->head_bb; thisBB != NULL; thisBB = nextBB) {
if (thisBB->jumpTarget != NULL) {
Tcl_DecrRefCount(thisBB->jumpTarget);
}
if (thisBB->foreignExceptions != NULL) {
ckfree((char*)(thisBB->foreignExceptions));
}
nextBB = thisBB->successor1;
if (thisBB->jtPtr != NULL) {
DeleteMirrorJumpTable(thisBB->jtPtr);
thisBB->jtPtr = NULL;
}
ckfree((char*)thisBB);
}
/* Free the label hash */
while ((hashEntry = Tcl_FirstHashEntry(&assemEnvPtr->labelHash,
&hashSearch)) != NULL) {
Tcl_DeleteHashEntry(hashEntry);
}
TclStackFree(interp, assemEnvPtr->parsePtr);
TclStackFree(interp, assemEnvPtr);
}
/*
*-----------------------------------------------------------------------------
*
* AssembleOneLine --
*
* Assembles a single command from an assembly language source.
*
* Results:
* Returns TCL_ERROR with an appropriate error message if the
* assembly fails. Returns TCL_OK if the assembly succeeds. Updates
* the assembly environment with the state of the assembly.
*
*-----------------------------------------------------------------------------
*/
static int
AssembleOneLine(AssemblyEnv* assemEnvPtr)
/* State of the assembly */
{
CompileEnv* envPtr = assemEnvPtr->envPtr;
/* Compilation environment being used for
* code gen */
Tcl_Interp* interp = (Tcl_Interp*) envPtr->iPtr;
/* Tcl interpreter */
Tcl_Parse* parsePtr = assemEnvPtr->parsePtr;
/* Parse of the line of code */
Tcl_Token* tokenPtr; /* Current token within the line of code */
Tcl_Obj* instNameObj = NULL;
/* Name of the instruction */
int tblind; /* Index in TalInstructionTable of the
* instruction */
enum TalInstType instType; /* Type of the instruction */
Tcl_Obj* operand1Obj = NULL;
/* First operand to the instruction */
const char* operand1; /* String rep of the operand */
int operand1Len; /* String length of the operand */
int opnd; /* Integer representation of an operand */
int litIndex; /* Literal pool index of a constant */
int localVar; /* LVT index of a local variable */
int flags; /* Flags for a basic block */
JumptableInfo* jtPtr; /* Pointer to a jumptable */
int infoIndex; /* Index of the jumptable in auxdata */
int status = TCL_ERROR; /* Return value from this function */
/* Make sure that the instruction name is known at compile time. */
tokenPtr = parsePtr->tokenPtr;
instNameObj = Tcl_NewObj();
Tcl_IncrRefCount(instNameObj);
if (GetNextOperand(assemEnvPtr, &tokenPtr, &instNameObj) != TCL_OK) {
return TCL_ERROR;
}
/* Look up the instruction name */
if (Tcl_GetIndexFromObjStruct(interp, instNameObj,
&TalInstructionTable[0].name,
sizeof(TalInstDesc), "instruction",
TCL_EXACT, &tblind) != TCL_OK) {
return TCL_ERROR;
}
/* Vector on the type of instruction being processed */
instType = TalInstructionTable[tblind].instType;
switch (instType) {
case ASSEM_PUSH:
if (parsePtr->numWords != 2) {
Tcl_WrongNumArgs(interp, 1, &instNameObj, "value");
goto cleanup;
}
if (GetNextOperand(assemEnvPtr, &tokenPtr, &operand1Obj) != TCL_OK) {
goto cleanup;
}
operand1 = Tcl_GetStringFromObj(operand1Obj, &operand1Len);
litIndex = TclRegisterNewLiteral(envPtr, operand1, operand1Len);
BBEmitInst1or4(assemEnvPtr, tblind, litIndex, 0);
break;
case ASSEM_1BYTE:
if (parsePtr->numWords != 1) {
Tcl_WrongNumArgs(interp, 1, &instNameObj, "");
goto cleanup;
}
BBEmitOpcode(assemEnvPtr, tblind, 0);
break;
case ASSEM_BEGIN_CATCH:
/*
* Emit the BEGIN_CATCH instruction with the code offset of the
* exception branch target instead of the exception range index.
* The correct index will be generated and inserted later, when
* catches are being resolved.
*/
if (parsePtr->numWords != 2) {
Tcl_WrongNumArgs(interp, 1, &instNameObj, "label");
goto cleanup;
}
if (GetNextOperand(assemEnvPtr, &tokenPtr, &operand1Obj) != TCL_OK) {
goto cleanup;
}
assemEnvPtr->curr_bb->jumpLine = assemEnvPtr->cmdLine;
assemEnvPtr->curr_bb->jumpOffset = envPtr->codeNext - envPtr->codeStart;
BBEmitInstInt4(assemEnvPtr, tblind, 0, 0);
assemEnvPtr->curr_bb->flags |= BB_BEGINCATCH;
StartBasicBlock(assemEnvPtr, BB_FALLTHRU, operand1Obj);
break;
case ASSEM_BOOL:
if (parsePtr->numWords != 2) {
Tcl_WrongNumArgs(interp, 1, &instNameObj, "boolean");
goto cleanup;
}
if (GetBooleanOperand(assemEnvPtr, &tokenPtr, &opnd) != TCL_OK) {
goto cleanup;
}
BBEmitInstInt1(assemEnvPtr, tblind, opnd, 0);
break;
case ASSEM_BOOL_LVT4:
if (parsePtr->numWords != 3) {
Tcl_WrongNumArgs(interp, 1, &instNameObj, "boolean varName");
goto cleanup;
}
if (GetBooleanOperand(assemEnvPtr, &tokenPtr, &opnd) != TCL_OK
|| (localVar = FindLocalVar(assemEnvPtr, &tokenPtr)) < 0) {
goto cleanup;
}
BBEmitInstInt1(assemEnvPtr, tblind, opnd, 0);
TclEmitInt4(localVar, envPtr);
break;
case ASSEM_CONCAT1:
if (parsePtr->numWords != 2) {
Tcl_WrongNumArgs(interp, 1, &instNameObj, "imm8");
goto cleanup;
}
if (GetIntegerOperand(assemEnvPtr, &tokenPtr, &opnd) != TCL_OK
|| CheckOneByte(interp, opnd) != TCL_OK
|| CheckStrictlyPositive(interp, opnd) != TCL_OK) {
goto cleanup;
}
BBEmitInstInt1(assemEnvPtr, tblind, opnd, opnd);
break;
case ASSEM_DICT_GET:
if (parsePtr->numWords != 2) {
Tcl_WrongNumArgs(interp, 1, &instNameObj, "count");
goto cleanup;
}
if (GetIntegerOperand(assemEnvPtr, &tokenPtr, &opnd) != TCL_OK
|| CheckStrictlyPositive(interp, opnd) != TCL_OK) {
goto cleanup;
}
BBEmitInstInt4(assemEnvPtr, tblind, opnd, opnd+1);
break;
case ASSEM_DICT_SET:
if (parsePtr->numWords != 3) {
Tcl_WrongNumArgs(interp, 1, &instNameObj, "count varName");
goto cleanup;
}
if (GetIntegerOperand(assemEnvPtr, &tokenPtr, &opnd) != TCL_OK
|| CheckStrictlyPositive(interp, opnd) != TCL_OK
|| (localVar = FindLocalVar(assemEnvPtr, &tokenPtr)) == -1) {
goto cleanup;
}
BBEmitInstInt4(assemEnvPtr, tblind, opnd, opnd+1);
TclEmitInt4(localVar, envPtr);
break;
case ASSEM_DICT_UNSET:
if (parsePtr->numWords != 3) {
Tcl_WrongNumArgs(interp, 1, &instNameObj, "count varName");
goto cleanup;
}
if (GetIntegerOperand(assemEnvPtr, &tokenPtr, &opnd) != TCL_OK
|| CheckStrictlyPositive(interp, opnd) != TCL_OK
|| (localVar = FindLocalVar(assemEnvPtr, &tokenPtr)) == -1) {
goto cleanup;
}
BBEmitInstInt4(assemEnvPtr, tblind, opnd, opnd);
TclEmitInt4(localVar, envPtr);
break;
case ASSEM_END_CATCH:
if (parsePtr->numWords != 1) {
Tcl_WrongNumArgs(interp, 1, &instNameObj, "");
goto cleanup;
}
assemEnvPtr->curr_bb->flags |= BB_ENDCATCH;
BBEmitOpcode(assemEnvPtr, tblind, 0);
StartBasicBlock(assemEnvPtr, BB_FALLTHRU, NULL);
break;
case ASSEM_EVAL:
/* TODO - Refactor this stuff into a subroutine
* that takes the inst code, the message ("script" or "expression")
* and an evaluator callback that calls TclCompileScript or
* TclCompileExpr.
*/
if (parsePtr->numWords != 2) {
Tcl_WrongNumArgs(interp, 1, &instNameObj,
((TalInstructionTable[tblind].tclInstCode
== INST_EVAL_STK) ? "script" : "expression"));
goto cleanup;
}
if (tokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
CompileEmbeddedScript(assemEnvPtr, tokenPtr+1,
TalInstructionTable+tblind);
} else if (GetNextOperand(assemEnvPtr, &tokenPtr,
&operand1Obj) != TCL_OK) {
goto cleanup;
} else {
operand1 = Tcl_GetStringFromObj(operand1Obj, &operand1Len);
litIndex = TclRegisterNewLiteral(envPtr, operand1, operand1Len);
/* Assumes that PUSH is the first slot! */
BBEmitInst1or4(assemEnvPtr, 0, litIndex, 0);
BBEmitOpcode(assemEnvPtr, tblind, 0);
}
break;
case ASSEM_INVOKE:
if (parsePtr->numWords != 2) {
Tcl_WrongNumArgs(interp, 1, &instNameObj, "count");
goto cleanup;
}
if (GetIntegerOperand(assemEnvPtr, &tokenPtr, &opnd) != TCL_OK
|| CheckStrictlyPositive(interp, opnd) != TCL_OK) {
goto cleanup;
}
BBEmitInst1or4(assemEnvPtr, tblind, opnd, opnd);
break;
case ASSEM_JUMP:
case ASSEM_JUMP4:
if (parsePtr->numWords != 2) {
Tcl_WrongNumArgs(interp, 1, &instNameObj, "label");
goto cleanup;
}
if (GetNextOperand(assemEnvPtr, &tokenPtr, &operand1Obj) != TCL_OK) {
goto cleanup;
}
assemEnvPtr->curr_bb->jumpOffset = envPtr->codeNext - envPtr->codeStart;
if (instType == ASSEM_JUMP) {
flags = BB_JUMP1;
BBEmitInstInt1(assemEnvPtr, tblind, 0, 0);
} else {
flags = 0;
BBEmitInstInt4(assemEnvPtr, tblind, 0, 0);
}
/* Start a new basic block at the instruction following the jump */
assemEnvPtr->curr_bb->jumpLine = assemEnvPtr->cmdLine;
if (TalInstructionTable[tblind].operandsConsumed != 0) {
flags |= BB_FALLTHRU;
}
StartBasicBlock(assemEnvPtr, flags, operand1Obj);
break;
case ASSEM_JUMPTABLE:
if (parsePtr->numWords != 2) {
Tcl_WrongNumArgs(interp, 1, &instNameObj, "table");
goto cleanup;
}
if (GetNextOperand(assemEnvPtr, &tokenPtr, &operand1Obj) != TCL_OK) {
goto cleanup;
}
jtPtr = (JumptableInfo*) ckalloc(sizeof(JumptableInfo));
Tcl_InitHashTable(&jtPtr->hashTable, TCL_STRING_KEYS);
assemEnvPtr->curr_bb->jumpLine = assemEnvPtr->cmdLine;
assemEnvPtr->curr_bb->jumpOffset = envPtr->codeNext - envPtr->codeStart;
/*fprintf(stderr, "bb %p jumpLine %d jumpOffset %d\n",
assemEnvPtr->curr_bb, assemEnvPtr->cmdLine,
envPtr->codeNext - envPtr->codeStart); fflush(stderr); */
infoIndex = TclCreateAuxData(jtPtr, &tclJumptableInfoType, envPtr);
/* fprintf(stderr, "auxdata index=%d\n", infoIndex); */
BBEmitInstInt4(assemEnvPtr, tblind, infoIndex, 0);
if (CreateMirrorJumpTable(assemEnvPtr, operand1Obj) != TCL_OK) {
goto cleanup;
}
StartBasicBlock(assemEnvPtr, BB_JUMPTABLE|BB_FALLTHRU, NULL);
break;
case ASSEM_LABEL:
if (parsePtr->numWords != 2) {
Tcl_WrongNumArgs(interp, 1, &instNameObj, "name");
goto cleanup;
}
if (GetNextOperand(assemEnvPtr, &tokenPtr, &operand1Obj) != TCL_OK) {
goto cleanup;
}
/* Add the (label_name, address) pair to the hash table */
if (DefineLabel(assemEnvPtr, Tcl_GetString(operand1Obj)) != TCL_OK) {
goto cleanup;
}
break;
case ASSEM_LINDEX_MULTI:
if (parsePtr->numWords != 2) {
Tcl_WrongNumArgs(interp, 1, &instNameObj, "count");
goto cleanup;
}
if (GetIntegerOperand(assemEnvPtr, &tokenPtr, &opnd) != TCL_OK
|| CheckStrictlyPositive(interp, opnd) != TCL_OK) {
goto cleanup;
}
BBEmitInstInt4(assemEnvPtr, tblind, opnd, opnd);
break;
case ASSEM_LIST:
if (parsePtr->numWords != 2) {
Tcl_WrongNumArgs(interp, 1, &instNameObj, "count");
goto cleanup;
}
if (GetIntegerOperand(assemEnvPtr, &tokenPtr, &opnd) != TCL_OK
|| CheckNonNegative(interp, opnd) != TCL_OK) {
goto cleanup;
}
BBEmitInstInt4(assemEnvPtr, tblind, opnd, opnd);
break;
case ASSEM_INDEX:
if (parsePtr->numWords != 2) {
Tcl_WrongNumArgs(interp, 1, &instNameObj, "count");
goto cleanup;
}
if (GetListIndexOperand(assemEnvPtr, &tokenPtr, &opnd) != TCL_OK) {
goto cleanup;
}
BBEmitInstInt4(assemEnvPtr, tblind, opnd, opnd);
break;
case ASSEM_LSET_FLAT:
if (parsePtr->numWords != 2) {
Tcl_WrongNumArgs(interp, 1, &instNameObj, "count");
goto cleanup;
}
if (GetIntegerOperand(assemEnvPtr, &tokenPtr, &opnd) != TCL_OK) {
goto cleanup;
}
if (opnd < 2) {
if (assemEnvPtr->flags & TCL_EVAL_DIRECT) {
Tcl_SetObjResult(interp,
Tcl_NewStringObj("operand must be >=2", -1));
Tcl_SetErrorCode(interp, "TCL", "ASSEM", "OPERAND>=2", NULL);
}
goto cleanup;
}
BBEmitInstInt4(assemEnvPtr, tblind, opnd, opnd);
break;
case ASSEM_LVT:
if (parsePtr->numWords != 2) {
Tcl_WrongNumArgs(interp, 1, &instNameObj, "varname");
goto cleanup;
}
if ((localVar = FindLocalVar(assemEnvPtr, &tokenPtr)) < 0) {
goto cleanup;
}
BBEmitInst1or4(assemEnvPtr, tblind, localVar, 0);
break;
case ASSEM_LVT1:
if (parsePtr->numWords != 2) {
Tcl_WrongNumArgs(interp, 1, &instNameObj, "varname");
goto cleanup;
}
if ((localVar = FindLocalVar(assemEnvPtr, &tokenPtr)) < 0
|| CheckOneByte(interp, localVar)) {
goto cleanup;
}
BBEmitInstInt1(assemEnvPtr, tblind, localVar, 0);
break;
case ASSEM_LVT1_SINT1:
if (parsePtr->numWords != 3) {
Tcl_WrongNumArgs(interp, 1, &instNameObj, "varName imm8");
goto cleanup;
}
if ((localVar = FindLocalVar(assemEnvPtr, &tokenPtr)) < 0
|| CheckOneByte(interp, localVar)
|| GetIntegerOperand(assemEnvPtr, &tokenPtr, &opnd) != TCL_OK
|| CheckSignedOneByte(interp, opnd)) {
goto cleanup;
}
BBEmitInstInt1(assemEnvPtr, tblind, localVar, 0);
TclEmitInt1(opnd, envPtr);
break;
case ASSEM_LVT4:
if (parsePtr->numWords != 2) {
Tcl_WrongNumArgs(interp, 1, &instNameObj, "varname");
goto cleanup;
}
if ((localVar = FindLocalVar(assemEnvPtr, &tokenPtr)) < 0) {
goto cleanup;
}
BBEmitInstInt4(assemEnvPtr, tblind, localVar, 0);
break;
case ASSEM_OVER:
if (parsePtr->numWords != 2) {
Tcl_WrongNumArgs(interp, 1, &instNameObj, "count");
goto cleanup;
}
if (GetIntegerOperand(assemEnvPtr, &tokenPtr, &opnd) != TCL_OK
|| CheckNonNegative(interp, opnd) != TCL_OK) {
goto cleanup;
}
BBEmitInstInt4(assemEnvPtr, tblind, opnd, opnd+1);
break;
case ASSEM_REGEXP:
if (parsePtr->numWords != 2) {
Tcl_WrongNumArgs(interp, 1, &instNameObj, "boolean");
goto cleanup;
}
if (GetBooleanOperand(assemEnvPtr, &tokenPtr, &opnd) != TCL_OK) {
goto cleanup;
}
{
int flags = TCL_REG_ADVANCED | (opnd ? TCL_REG_NOCASE : 0);
BBEmitInstInt1(assemEnvPtr, tblind, flags, 0);
}
break;
case ASSEM_REVERSE:
if (parsePtr->numWords != 2) {
Tcl_WrongNumArgs(interp, 1, &instNameObj, "count");
goto cleanup;
}
if (GetIntegerOperand(assemEnvPtr, &tokenPtr, &opnd) != TCL_OK
|| CheckNonNegative(interp, opnd) != TCL_OK) {
goto cleanup;
}
BBEmitInstInt4(assemEnvPtr, tblind, opnd, opnd);
break;
case ASSEM_SINT1:
if (parsePtr->numWords != 2) {
Tcl_WrongNumArgs(interp, 1, &instNameObj, "imm8");
goto cleanup;
}
if (GetIntegerOperand(assemEnvPtr, &tokenPtr, &opnd) != TCL_OK
|| CheckSignedOneByte(interp, opnd) != TCL_OK) {
goto cleanup;
}
BBEmitInstInt1(assemEnvPtr, tblind, opnd, 0);
break;
case ASSEM_SINT4_LVT4:
if (parsePtr->numWords != 3) {
Tcl_WrongNumArgs(interp, 1, &instNameObj, "count varName");
goto cleanup;
}
if (GetIntegerOperand(assemEnvPtr, &tokenPtr, &opnd) != TCL_OK
|| (localVar = FindLocalVar(assemEnvPtr, &tokenPtr)) == -1) {
goto cleanup;
}
BBEmitInstInt4(assemEnvPtr, tblind, opnd, 0);
TclEmitInt4(localVar, envPtr);
break;
default:
Tcl_Panic("Instruction \"%s\" could not be found, can't happen\n",
Tcl_GetString(instNameObj));
}
status = TCL_OK;
cleanup:
if (instNameObj) {
Tcl_DecrRefCount(instNameObj);
}
if (operand1Obj) {
Tcl_DecrRefCount(operand1Obj);
}
return status;
}
/*
*-----------------------------------------------------------------------------
*
* CompileEmbeddedScript --
*
* Compile an embedded 'eval' or 'expr' that appears in assembly code.
*
* This procedure is called when the 'eval' or 'expr' assembly directive
* is encountered, and the argument to the directive is a simple word that
* requires no substitution. The appropriate compiler (TclCompileScript or
* TclCompileExpr) is invoked recursively, and emits bytecode.
*
* Before the compiler is invoked, the compilation environment's stack
* consumption is reset to zero. Upon return from the compilation, the
* net stack effect of the compilation is in the compiler env, and this
* stack effect is posted to the assembler environment. The compile
* environment's stack consumption is then restored to what it was
* before (which is actually the state of the stack on entry to the block
* of assembly code).
*
* Any exception ranges pushed by the compilation are copied to the basic
* block and removed from the compiler environment. They will be rebuilt at
* the end of assembly, when the exception stack depth is actually known.
*
*-----------------------------------------------------------------------------
*/
static void
CompileEmbeddedScript(AssemblyEnv* assemEnvPtr,
/* Assembler environment */
Tcl_Token* tokenPtr,
/* Tcl_Token containing the script */
TalInstDesc* instPtr)
/* Instruction that determines whether
* the script is 'expr' or 'eval' */
{
/*
* The expression or script is not only known at compile time,
* but actually a "simple word". It can be compiled inline by
* invoking the compiler recursively.
*/
CompileEnv* envPtr = assemEnvPtr->envPtr;
/* Compilation environment */
Tcl_Interp* interp = (Tcl_Interp*) envPtr->iPtr;
/* Tcl interpreter */
/*
* Save away the stack depth and reset it before compiling the script.
* We'll record the stack usage of the script in the BasicBlock, and
* accumulate it together with the stack usage of the enclosing assembly
* code.
*/
int savedStackDepth = envPtr->currStackDepth;
int savedMaxStackDepth = envPtr->maxStackDepth;
int savedCodeIndex = envPtr->codeNext - envPtr->codeStart;
int savedExceptArrayNext = envPtr->exceptArrayNext;
envPtr->currStackDepth = 0;
envPtr->maxStackDepth = 0;
StartBasicBlock(assemEnvPtr, BB_FALLTHRU, NULL);
switch(instPtr->tclInstCode) {
case INST_EVAL_STK:
TclCompileScript(interp, tokenPtr->start, tokenPtr->size, envPtr);
break;
case INST_EXPR_STK:
TclCompileExpr(interp, tokenPtr->start, tokenPtr->size, envPtr, 1);
break;
default:
Tcl_Panic("no ASSEM_EVAL case for %s (%d), can't happen",
instPtr->name, instPtr->tclInstCode);
}
/*
* Roll up the stack usage of the embedded block into the assembler
* environment.
*/
SyncStackDepth(assemEnvPtr);
envPtr->currStackDepth = savedStackDepth;
envPtr->maxStackDepth = savedMaxStackDepth;
/*
* Save any exception ranges that were pushed by the compiler, They
* will need to be fixed up once the stack depth is known.
*/
MoveExceptionRangesToBasicBlock(assemEnvPtr, savedCodeIndex,
savedExceptArrayNext);
/* Flush the current basic block */
StartBasicBlock(assemEnvPtr, BB_FALLTHRU, NULL);
}
/*
*-----------------------------------------------------------------------------
*
* SyncStackDepth --
*
* Copies the stack depth from the compile environment to a basic
* block.
*
* Side effects:
* Current and max stack depth in the current basic block are
* adjusted.
*
* This procedure is called on return from invoking the compiler for
* the 'eval' and 'expr' operations. It adjusts the stack depth of the
* current basic block to reflect the stack required by the just-compiled
* code.
*
*-----------------------------------------------------------------------------
*/
static void
SyncStackDepth(AssemblyEnv* assemEnvPtr)
/* Assembly environment */
{
CompileEnv* envPtr = assemEnvPtr->envPtr;
/* Compilation environment */
BasicBlock* curr_bb = assemEnvPtr->curr_bb;
/* Current basic block */
int maxStackDepth = curr_bb->finalStackDepth + envPtr->maxStackDepth;
/* Max stack depth in the basic block */
if (maxStackDepth > curr_bb->maxStackDepth) {
curr_bb->maxStackDepth = maxStackDepth;
}
curr_bb->finalStackDepth += envPtr->currStackDepth;
}
/*
*-----------------------------------------------------------------------------
*
* MoveExceptionRangesToBasicBlock --
*
* Removes exception ranges that were created by compiling an embedded
* script from the CompileEnv, and stores them in the BasicBlock. They
* will be reinstalled, at the correct stack depth, after control flow
* analysis is complete on the assembly code.
*
*-----------------------------------------------------------------------------
*/
static void
MoveExceptionRangesToBasicBlock(AssemblyEnv* assemEnvPtr,
/* Assembler environment */
int savedCodeIndex,
/* Start of the embedded code */
int savedExceptArrayNext)
/* Saved index of the end of the exception
* range array */
{
CompileEnv* envPtr = assemEnvPtr->envPtr;
/* Compilation environment */
BasicBlock* curr_bb = assemEnvPtr->curr_bb;
/* Current basic block */
int exceptionCount = envPtr->exceptArrayNext - savedExceptArrayNext;
/* Number of ranges that must be moved */
int i;
if (exceptionCount == 0) {
/* Nothing to do */
return;
}
/*
* Save the exception ranges in the basic block. They will be re-added
* at the conclusion of assembly; at this time, the INST_BEGIN_CATCH
* instructions in the block will be adjusted from whatever range
* indices they have [savedExceptArrayNext .. envPtr->exceptArrayNext)
* to the indices that the exceptions acquire. The saved exception ranges
* are converted to a relative nesting depth. The depth will be recomputed
* once flow analysis has determined the actual stack depth of the block.
*/
/*fprintf(stderr, "basic block %p has %d exceptions starting at %d\n",
curr_bb, exceptionCount, savedExceptArrayNext); */
curr_bb->foreignExceptionBase = savedExceptArrayNext;
curr_bb->foreignExceptionCount = exceptionCount;
curr_bb->foreignExceptions = (ExceptionRange*)
ckalloc(exceptionCount * sizeof(ExceptionRange));
memcpy(curr_bb->foreignExceptions,
envPtr->exceptArrayPtr + savedExceptArrayNext,
exceptionCount * sizeof(ExceptionRange));
for (i = 0; i < exceptionCount; ++i) {
curr_bb->foreignExceptions[i].nestingLevel -= envPtr->exceptDepth;
}
envPtr->exceptArrayNext = savedExceptArrayNext;
}
/*
*-----------------------------------------------------------------------------
*
* CreateMirrorJumpTable --
*
* Makes a jump table with comparison values and assembly code labels.
*
* Results:
* Returns a standard Tcl status, with an error message in the interpreter
* on error.
*
* Side effects:
* Initializes the jump table pointer in the current basic block to
* a JumptableInfo. The keys in the JumptableInfo are the comparison
* strings. The values, instead of being jump displacements, are
* Tcl_Obj's with the code labels.
*/
static int
CreateMirrorJumpTable(AssemblyEnv* assemEnvPtr,
/* Assembly environment */
Tcl_Obj* jumps)
/* List of alternating keywords and labels */
{
int objc; /* Number of elements in the 'jumps' list */
Tcl_Obj** objv; /* Pointers to the elements in the list */
CompileEnv* envPtr = assemEnvPtr->envPtr;
/* Compilation environment */
Tcl_Interp* interp = (Tcl_Interp*) envPtr->iPtr;
/* Tcl interpreter */
BasicBlock* bbPtr = assemEnvPtr->curr_bb;
/* Current basic block */
JumptableInfo* jtPtr;
Tcl_HashTable* jtHashPtr; /* Hashtable in the JumptableInfo */
Tcl_HashEntry* hashEntry; /* Entry for a key in the hashtable */
int isNew; /* Flag==1 if the key is not yet in the table */
Tcl_Obj* result; /* Error message */
int i;
if (Tcl_ListObjGetElements(interp, jumps, &objc, &objv) != TCL_OK) {
return TCL_ERROR;
}
if (objc % 2 != 0) {
if (assemEnvPtr->flags & TCL_EVAL_DIRECT) {
Tcl_SetObjResult(interp,
Tcl_NewStringObj("jump table must have an "
"even number of list "
"elements", -1));
Tcl_SetErrorCode(interp, "TCL", "ASSEM", "BADJUMPTABLE", NULL);
}
return TCL_ERROR;
}
/* Allocate the jumptable */
jtPtr = (JumptableInfo*) ckalloc(sizeof(JumptableInfo));
jtHashPtr = &(jtPtr->hashTable);
Tcl_InitHashTable(jtHashPtr, TCL_STRING_KEYS);
/* Fill the keys and labels into the table */
/* fprintf(stderr, "jump table {\n"); */
for (i = 0; i < objc; i+=2) {
/* fprintf(stderr, " %s -> %s\n", Tcl_GetString(objv[i]),
Tcl_GetString(objv[i+1])); fflush(stderr); */
hashEntry = Tcl_CreateHashEntry(jtHashPtr, Tcl_GetString(objv[i]),
&isNew);
if (!isNew) {
if (assemEnvPtr->flags & TCL_EVAL_DIRECT) {
result = Tcl_NewStringObj("duplicate entry in jump table for "
"\"", -1);
Tcl_AppendObjToObj(result, objv[i]);
Tcl_AppendToObj(result, "\"", -1);
Tcl_SetObjResult(interp, result);
Tcl_SetErrorCode(interp, "TCL", "ASSEM", "DUPJUMPTABLEENTRY");
DeleteMirrorJumpTable(jtPtr);
return TCL_ERROR;
}
}
Tcl_SetHashValue(hashEntry, (ClientData) objv[i+1]);
Tcl_IncrRefCount(objv[i+1]);
}
/* fprintf(stderr, "}\n"); fflush(stderr); */
/* Put the mirror jumptable in the basic block struct */
bbPtr->jtPtr = jtPtr;
return TCL_OK;
}
/*
*-----------------------------------------------------------------------------
*
* DeleteMirrorJumpTable --
*
* Cleans up a jump table when the basic block is deleted.
*
*-----------------------------------------------------------------------------
*/
static void
DeleteMirrorJumpTable(JumptableInfo* jtPtr)
{
Tcl_HashTable* jtHashPtr = &jtPtr->hashTable;
/* Hash table pointer */
Tcl_HashSearch search; /* Hash search control */
Tcl_HashEntry* entry; /* Hash table entry containing a jump label */
Tcl_Obj* label; /* Jump label from the hash table */
for (entry = Tcl_FirstHashEntry(jtHashPtr, &search);
entry != NULL;
entry = Tcl_NextHashEntry(&search)) {
label = (Tcl_Obj*) Tcl_GetHashValue(entry);
Tcl_DecrRefCount(label);
Tcl_SetHashValue(entry, NULL);
}
Tcl_DeleteHashTable(jtHashPtr);
ckfree((char*)jtPtr);
}
/*
*-----------------------------------------------------------------------------
*
* GetNextOperand --
*
* Retrieves the next operand in sequence from an assembly
* instruction, and makes sure that its value is known at
* compile time.
*
* Results:
* If successful, returns TCL_OK and leaves a Tcl_Obj with
* the operand text in *operandObjPtr. In case of failure,
* returns TCL_ERROR and leaves *operandObjPtr untouched.
*
* Side effects:
* Advances *tokenPtrPtr around the token just processed.
*
*-----------------------------------------------------------------------------
*/
static int
GetNextOperand(AssemblyEnv* assemEnvPtr,
/* Assembler environment */
Tcl_Token** tokenPtrPtr,
/* INPUT/OUTPUT: Pointer to the token
* holding the operand */
Tcl_Obj** operandObjPtr)
/* OUTPUT: Tcl object holding the
* operand text with \-substitutions
* done. */
{
Tcl_Interp* interp = (Tcl_Interp*) assemEnvPtr->envPtr->iPtr;
Tcl_Obj* operandObj = Tcl_NewObj();
if (!TclWordKnownAtCompileTime(*tokenPtrPtr, operandObj)) {
Tcl_DecrRefCount(operandObj);
if (assemEnvPtr->flags & TCL_EVAL_DIRECT) {
Tcl_SetObjResult(interp,
Tcl_NewStringObj("assembly code may not "
"contain substitutions", -1));
Tcl_SetErrorCode(interp, "TCL", "ASSEM", "NOSUBST", NULL);
}
return TCL_ERROR;
}
*tokenPtrPtr = TokenAfter(*tokenPtrPtr);
Tcl_IncrRefCount(operandObj);
*operandObjPtr = operandObj;
return TCL_OK;
}
/*
*-----------------------------------------------------------------------------
*
* GetBooleanOperand --
*
* Retrieves a Boolean operand from the input stream and advances
* the token pointer.
*
* Results:
* Returns a standard Tcl result (with an error message in the
* interpreter on failure).
*
* Side effects:
* Stores the Boolean value in (*result) and advances (*tokenPtrPtr)
* to the next token.
*
*-----------------------------------------------------------------------------
*/
static int
GetBooleanOperand(AssemblyEnv* assemEnvPtr,
/* Assembly environment */
Tcl_Token** tokenPtrPtr,
/* Current token from the parser */
int* result)
/* OUTPUT: Integer extracted from the token */
{
CompileEnv* envPtr = assemEnvPtr->envPtr;
/* Compilation environment */
Tcl_Interp* interp = (Tcl_Interp*) envPtr->iPtr;
/* Tcl interpreter */
Tcl_Token* tokenPtr = *tokenPtrPtr;
/* INOUT: Pointer to the next token
* in the source code */
Tcl_Obj* intObj = Tcl_NewObj();
/* Integer from the source code */
int status; /* Tcl status return */
/* Extract the next token as a string */
Tcl_IncrRefCount(intObj);
if (GetNextOperand(assemEnvPtr, tokenPtrPtr, &intObj) != TCL_OK) {
Tcl_DecrRefCount(intObj);
return TCL_ERROR;
}
/* Convert to an integer, advance to the next token and return */
status = Tcl_GetBooleanFromObj(interp, intObj, result);
Tcl_DecrRefCount(intObj);
*tokenPtrPtr = TokenAfter(tokenPtr);
return status;
}
/*
*-----------------------------------------------------------------------------
*
* GetIntegerOperand --
*
* Retrieves an integer operand from the input stream and advances
* the token pointer.
*
* Results:
* Returns a standard Tcl result (with an error message in the
* interpreter on failure).
*
* Side effects:
* Stores the integer value in (*result) and advances (*tokenPtrPtr)
* to the next token.
*
*-----------------------------------------------------------------------------
*/
static int
GetIntegerOperand(AssemblyEnv* assemEnvPtr,
/* Assembly environment */
Tcl_Token** tokenPtrPtr,
/* Current token from the parser */
int* result)
/* OUTPUT: Integer extracted from the token */
{
CompileEnv* envPtr = assemEnvPtr->envPtr;
/* Compilation environment */
Tcl_Interp* interp = (Tcl_Interp*) envPtr->iPtr;
/* Tcl interpreter */
Tcl_Token* tokenPtr = *tokenPtrPtr;
/* INOUT: Pointer to the next token
* in the source code */
Tcl_Obj* intObj = Tcl_NewObj();
/* Integer from the source code */
int status; /* Tcl status return */
/* Extract the next token as a string */
Tcl_IncrRefCount(intObj);
if (GetNextOperand(assemEnvPtr, tokenPtrPtr, &intObj) != TCL_OK) {
Tcl_DecrRefCount(intObj);
return TCL_ERROR;
}
/* Convert to an integer, advance to the next token and return */
status = Tcl_GetIntFromObj(interp, intObj, result);
Tcl_DecrRefCount(intObj);
*tokenPtrPtr = TokenAfter(tokenPtr);
return status;
}
/*
*-----------------------------------------------------------------------------
*
* GetListIndexOperand --
*
* Gets the value of an operand intended to serve as a list index.
*
* Results:
* Returns a standard Tcl result: TCL_OK if the parse is successful
* and TCL_ERROR (with an appropriate error message) if the parse fails.
*
* Side effects:
* Stores the list index at '*index'. Values between -1 and 0x7fffffff
* have their natural meaning; values between -2 and -0x80000000
* represent 'end-2-N'.
*
*-----------------------------------------------------------------------------
*/
static int
GetListIndexOperand(
AssemblyEnv* assemEnvPtr,
/* Assembly environment */
Tcl_Token** tokenPtrPtr,
/* Current token from the parser */
int* result)
/* OUTPUT: Integer extracted from the token */
{
CompileEnv* envPtr = assemEnvPtr->envPtr;
/* Compilation environment */
Tcl_Interp* interp = (Tcl_Interp*) envPtr->iPtr;
/* Tcl interpreter */
Tcl_Token* tokenPtr = *tokenPtrPtr;
/* INOUT: Pointer to the next token
* in the source code */
Tcl_Obj* intObj = Tcl_NewObj();
/* Integer from the source code */
int status; /* Tcl status return */
/* Extract the next token as a string */
Tcl_IncrRefCount(intObj);
if (GetNextOperand(assemEnvPtr, tokenPtrPtr, &intObj) != TCL_OK) {
Tcl_DecrRefCount(intObj);
return TCL_ERROR;
}
/* Convert to an integer, advance to the next token and return */
status = TclGetIntForIndex(interp, intObj, -2, result);
Tcl_DecrRefCount(intObj);
*tokenPtrPtr = TokenAfter(tokenPtr);
return status;
}
/*
*-----------------------------------------------------------------------------
*
* FindLocalVar --
*
* Gets the name of a local variable from the input stream and advances
* the token pointer.
*
* Results:
* Returns the LVT index of the local variable. Returns -1 if
* the variable is non-local, not known at compile time, or
* cannot be installed in the LVT (leaving an error message in
* the interpreter result if necessary).
*
* Side effects:
* Advances the token pointer. May define a new LVT slot if the
* variable has not yet been seen and the execution context allows
* for it.
*
*-----------------------------------------------------------------------------
*/
static int
FindLocalVar(AssemblyEnv* assemEnvPtr,
Tcl_Token** tokenPtrPtr)
{
CompileEnv* envPtr = assemEnvPtr->envPtr;
/* Compilation environment */
Tcl_Interp* interp = (Tcl_Interp*) envPtr->iPtr;
/* Tcl interpreter */
Tcl_Token* tokenPtr = *tokenPtrPtr;
/* INOUT: Pointer to the next token
* in the source code */
Tcl_Obj* varNameObj = Tcl_NewObj();
/* Name of the variable */
const char* varNameStr;
int varNameLen;
int localVar; /* Index of the variable in the LVT */
Tcl_IncrRefCount(varNameObj);
if (GetNextOperand(assemEnvPtr, tokenPtrPtr, &varNameObj) != TCL_OK) {
Tcl_DecrRefCount(varNameObj);
return -1;
}
varNameStr = Tcl_GetStringFromObj(varNameObj, &varNameLen);
if (CheckNamespaceQualifiers(interp, varNameStr, varNameLen)) {
return -1;
}
localVar = TclFindCompiledLocal(varNameStr, varNameLen, 1, envPtr);
Tcl_DecrRefCount(varNameObj);
if (localVar == -1) {
if (assemEnvPtr->flags & TCL_EVAL_DIRECT) {
Tcl_SetObjResult(interp,
Tcl_NewStringObj("cannot use this instruction"
" to create a variable"
" in a non-proc context", -1));
Tcl_SetErrorCode(interp, "TCL", "ASSEM", "LVT", NULL);
}
return -1;
}
*tokenPtrPtr = TokenAfter(tokenPtr);
return localVar;
}
/*
*-----------------------------------------------------------------------------
*
* CheckNamespaceQualifiers --
*
* Verify that a variable name has no namespace qualifiers before
* attempting to install it in the LVT.
*
* Results:
* On success, returns TCL_OK. On failure, returns TCL_ERROR and
* stores an error message in the interpreter result.
*
*-----------------------------------------------------------------------------
*/
static int
CheckNamespaceQualifiers(Tcl_Interp* interp,
/* Tcl interpreter for error reporting */
const char* name,
/* Variable name to check */
int nameLen)
/* Length of the variable */
{
Tcl_Obj* result; /* Error message */
const char* p;
for (p = name; p+2 < name+nameLen; p++) {
if ((*p == ':') && (p[1] == ':')) {
result = Tcl_NewStringObj("variable \"", -1);
Tcl_AppendToObj(result, name, -1);
Tcl_AppendToObj(result, "\" is not local", -1);
Tcl_SetObjResult(interp, result);
Tcl_SetErrorCode(interp, "TCL", "ASSEM", "NONLOCAL", name,
NULL);
return TCL_ERROR;
}
}
return TCL_OK;
}
/*
*-----------------------------------------------------------------------------
*
* CheckOneByte --
*
* Verify that a constant fits in a single byte in the instruction stream.
*
* Results:
* On success, returns TCL_OK. On failure, returns TCL_ERROR and
* stores an error message in the interpreter result.
*
* This code is here primarily to verify that instructions like INCR_SCALAR1
* are possible on a given local variable. The fact that there is no
* INCR_SCALAR4 is puzzling.
*
*-----------------------------------------------------------------------------
*/
static int
CheckOneByte(Tcl_Interp* interp,
/* Tcl interpreter for error reporting */
int value) /* Value to check */
{
Tcl_Obj* result; /* Error message */
if (value < 0 || value > 0xff) {
result = Tcl_NewStringObj("operand does not fit in one byte", -1);
Tcl_SetObjResult(interp, result);
Tcl_SetErrorCode(interp, "TCL", "ASSEM", "1BYTE", NULL);
return TCL_ERROR;
}
return TCL_OK;
}
/*
*-----------------------------------------------------------------------------
*
* CheckSignedOneByte --
*
* Verify that a constant fits in a single signed byte in the instruction
* stream.
*
* Results:
* On success, returns TCL_OK. On failure, returns TCL_ERROR and
* stores an error message in the interpreter result.
*
* This code is here primarily to verify that instructions like INCR_SCALAR1
* are possible on a given local variable. The fact that there is no
* INCR_SCALAR4 is puzzling.
*
*-----------------------------------------------------------------------------
*/
static int
CheckSignedOneByte(Tcl_Interp* interp,
/* Tcl interpreter for error reporting */
int value) /* Value to check */
{
Tcl_Obj* result; /* Error message */
if (value > 0x7f || value < -0x80) {
result = Tcl_NewStringObj("operand does not fit in one byte", -1);
Tcl_SetObjResult(interp, result);
Tcl_SetErrorCode(interp, "TCL", "ASSEM", "1BYTE", NULL);
return TCL_ERROR;
}
return TCL_OK;
}
/*
*-----------------------------------------------------------------------------
*
* CheckNonNegative --
*
* Verify that a constant is nonnegative
*
* Results:
* On success, returns TCL_OK. On failure, returns TCL_ERROR and
* stores an error message in the interpreter result.
*
* This code is here primarily to verify that instructions like INCR_INVOKE
* are consuming a positive number of operands
*
*-----------------------------------------------------------------------------
*/
static int
CheckNonNegative(Tcl_Interp* interp,
/* Tcl interpreter for error reporting */
int value) /* Value to check */
{
Tcl_Obj* result; /* Error message */
if (value < 0) {
result = Tcl_NewStringObj("operand must be nonnegative", -1);
Tcl_SetObjResult(interp, result);
Tcl_SetErrorCode(interp, "TCL", "ASSEM", "NONNEGATIVE", NULL);
return TCL_ERROR;
}
return TCL_OK;
}
/*
*-----------------------------------------------------------------------------
*
* CheckStrictlyPositive --
*
* Verify that a constant is positive
*
* Results:
* On success, returns TCL_OK. On failure, returns TCL_ERROR and
* stores an error message in the interpreter result.
*
* This code is here primarily to verify that instructions like INCR_INVOKE
* are consuming a positive number of operands
*
*-----------------------------------------------------------------------------
*/
static int
CheckStrictlyPositive(Tcl_Interp* interp,
/* Tcl interpreter for error reporting */
int value) /* Value to check */
{
Tcl_Obj* result; /* Error message */
if (value <= 0) {
result = Tcl_NewStringObj("operand must be positive", -1);
Tcl_SetObjResult(interp, result);
Tcl_SetErrorCode(interp, "TCL", "ASSEM", "POSITIVE", NULL);
return TCL_ERROR;
}
return TCL_OK;
}
/*
*-----------------------------------------------------------------------------
*
* DefineLabel --
*
* Defines a label appearing in the assembly sequence.
*
* Results:
* Returns a standard Tcl result. Returns TCL_OK and an empty result
* if the definition succeeds; returns TCL_ERROR and an appropriate
* message if a duplicate definition is found.
*
*-----------------------------------------------------------------------------
*/
static int
DefineLabel(AssemblyEnv* assemEnvPtr, /* Assembly environment */
const char* labelName) /* Label being defined */
{
CompileEnv* envPtr = assemEnvPtr->envPtr;
/* Compilation environment */
Tcl_Interp* interp = (Tcl_Interp*) envPtr->iPtr;
/* Tcl interpreter */
Tcl_HashEntry* entry; /* Label's entry in the symbol table */
int isNew; /* Flag == 1 iff the label was previously
* undefined */
Tcl_Obj* result; /* Error message */
/* TODO - This can now be simplified! */
StartBasicBlock(assemEnvPtr, BB_FALLTHRU, NULL);
/* Look up the newly-defined label in the symbol table */
entry = Tcl_CreateHashEntry(&assemEnvPtr->labelHash, labelName, &isNew);
if (isNew) {
/* This is the first appearance of the label in the code */
Tcl_SetHashValue(entry, assemEnvPtr->curr_bb);
} else {
/* This is a duplicate label */
if (assemEnvPtr-> flags & (TCL_EVAL_DIRECT)) {
result = Tcl_NewStringObj("duplicate definition "
"of label \"", -1);
Tcl_AppendToObj(result, labelName, -1);
Tcl_AppendToObj(result, "\"", -1);
Tcl_SetObjResult(interp, result);
Tcl_SetErrorCode(interp, "TCL", "ASSEM", "DUPLABEL",
labelName, NULL);
}
return TCL_ERROR;
}
return TCL_OK;
}
/*
*-----------------------------------------------------------------------------
*
* StartBasicBlock --
*
* Starts a new basic block when a label or jump is encountered.
*
* Results:
* Returns a pointer to the BasicBlock structure of the new
* basic block.
*
*-----------------------------------------------------------------------------
*/
static BasicBlock*
StartBasicBlock(AssemblyEnv* assemEnvPtr,
/* Assembly environment */
int flags, /* Flags to apply to the basic block
* being closed, if there is one. */
Tcl_Obj* jumpLabel)
/* Label of the location that the
* block jumps to, or NULL if the block
* does not jump */
{
CompileEnv* envPtr = assemEnvPtr->envPtr;
/* Compilation environment */
BasicBlock* newBB; /* BasicBlock structure for the new block */
BasicBlock* currBB = assemEnvPtr->curr_bb;
/* Coalesce zero-length blocks */
if (currBB->startOffset == envPtr->codeNext - envPtr->codeStart) {
currBB->startLine = assemEnvPtr->cmdLine;
return currBB;
}
/* Make the new basic block */
newBB = AllocBB(assemEnvPtr);
/* Record the jump target if there is one. */
if ((currBB->jumpTarget = jumpLabel) != NULL) {
Tcl_IncrRefCount(currBB->jumpTarget);
}
/* Record the fallthrough if there is one. */
currBB->flags |= flags;
/* Record the successor block */
currBB->successor1 = newBB;
assemEnvPtr->curr_bb = newBB;
return newBB;
}
/*
*-----------------------------------------------------------------------------
*
* AllocBB --
*
* Allocates a new basic block
*
* Results:
* Returns a pointer to the newly allocated block, which is initialized
* to contain no code and begin at the current instruction pointer.
*
*-----------------------------------------------------------------------------
*/
static BasicBlock *
AllocBB(AssemblyEnv* assemEnvPtr)
/* Assembly environment */
{
CompileEnv* envPtr = assemEnvPtr->envPtr;
BasicBlock * bb = (BasicBlock *) ckalloc(sizeof(BasicBlock));
bb->originalStartOffset =
bb->startOffset = envPtr->codeNext - envPtr->codeStart;
bb->startLine = assemEnvPtr->cmdLine + 1;
bb->jumpOffset = -1;
bb->jumpLine = -1;
bb->prevPtr = assemEnvPtr->curr_bb;
bb->predecessor = NULL;
bb->successor1 = NULL;
bb->jumpTarget = NULL;
bb->initialStackDepth = 0;
bb->minStackDepth = 0;
bb->maxStackDepth = 0;
bb->finalStackDepth = 0;
bb->enclosingCatch = NULL;
bb->foreignExceptionBase = -1;
bb->foreignExceptionCount = 0;
bb->foreignExceptions = NULL;
bb->jtPtr = NULL;
bb->flags = 0;
return bb;
}
/*
*-----------------------------------------------------------------------------
*
* FinishAssembly --
*
* Postprocessing after all bytecode has been generated for a block
* of assembly code.
*
* Results:
* Returns a standard Tcl result, with an error message left in the
* interpreter if appropriate.
*
* Side effects:
* The program is checked to see if any undefined labels remain.
* The initial stack depth of all the basic blocks in the flow graph
* is calculated and saved. The stack balance on exit is computed,
* checked and saved.
*
*-----------------------------------------------------------------------------
*/
static int
FinishAssembly(AssemblyEnv* assemEnvPtr)
/* Assembly environment */
{
int mustMove; /* Amount by which the code needs to be
* grown because of expanding jumps */
/*
* Resolve the targets of all jumps and determine whether code needs
* to be moved around.
*/
if (CalculateJumpRelocations(assemEnvPtr, &mustMove)) {
return TCL_ERROR;
}
/* Move the code if necessary */
if (mustMove) {
MoveCodeForJumps(assemEnvPtr, mustMove);
}
/* Resolve jump target labels to bytecode offsets */
FillInJumpOffsets(assemEnvPtr);
/* Label each basic block with its catch context. Quit on inconsistency */
if (ProcessCatches(assemEnvPtr) != TCL_OK) {
return TCL_ERROR;
}
/*
* Make sure that no block accessible from a catch's error exit that hasn't
* popped the exception stack can throw an exception.
*/
if (CheckForThrowInWrongContext(assemEnvPtr) != TCL_OK) {
return TCL_ERROR;
}
/* Compute stack balance throughout the program */
if (CheckStack(assemEnvPtr) != TCL_OK) {
return TCL_ERROR;
}
/* TODO - Check for unreachable code */
/* Maybe not - unreachable code is Mostly Harmless. */
return TCL_OK;
}
/*
*-----------------------------------------------------------------------------
*
* CalculateJumpRelocations --
*
* Calculate any movement that has to be done in the assembly code to
* expand JUMP1 instructions to JUMP4 (because they jump more than
* a 1-byte range).
*
* Results:
* Returns a standard Tcl result, with an appropriate error message
* if anything fails.
*
* Side effects:
* Sets the 'startOffset' pointer in every basic block to the new
* origin of the block, and turns off JUMP1 flags on instructions that
* must be expanded (and adjusts them to the corresponding JUMP4's)
* Does *not* store the jump offsets at this point.
*
* Sets *mustMove to 1 if and only if at least one instruction changed
* size so the code must be moved.
*
* As a side effect, also checks for undefined labels
* and reports them.
*
*-----------------------------------------------------------------------------
*/
static int
CalculateJumpRelocations(AssemblyEnv* assemEnvPtr,
/* Assembler environment */
int* mustMove)
/* OUTPUT: Number of bytes that have been
* added to the code */
{
CompileEnv* envPtr = assemEnvPtr->envPtr;
/* Compilation environment */
BasicBlock* bbPtr; /* Pointer to a basic block being checked */
Tcl_HashEntry* entry; /* Exit label's entry in the symbol table */
BasicBlock* jumpTarget; /* Basic block where the jump goes */
int motion; /* Amount by which the code has expanded */
int offset; /* Offset in the bytecode from a jump
* instruction to its target */
unsigned opcode; /* Opcode in the bytecode being adjusted */
/* Iterate through basic blocks as long as a change results in
* code expansion */
*mustMove = 0;
do {
motion = 0;
for (bbPtr = assemEnvPtr->head_bb;
bbPtr != NULL;
bbPtr=bbPtr->successor1) {
/*
* Advance the basic block start offset by however many bytes
* we have inserted in the code up to this point
*/
bbPtr->startOffset += motion;
/*
* If the basic block references a label (and hence performs
* a jump), find the location of the label. Report an error if
* the label is missing.
*/
if (bbPtr->jumpTarget != NULL) {
entry = Tcl_FindHashEntry(&assemEnvPtr->labelHash,
Tcl_GetString(bbPtr->jumpTarget));
if (entry == NULL) {
ReportUndefinedLabel(assemEnvPtr, bbPtr,
bbPtr->jumpTarget);
return TCL_ERROR;
}
/*
* If the instruction is a JUMP1, turn it into a JUMP4 if its
* target is out of range.
*/
jumpTarget = (BasicBlock*) Tcl_GetHashValue(entry);
if (bbPtr->flags & BB_JUMP1) {
offset = jumpTarget->startOffset
- (bbPtr->jumpOffset + motion);
if (offset < -0x80 || offset > 0x7f) {
opcode = TclGetUInt1AtPtr(envPtr->codeStart
+ bbPtr->jumpOffset);
++opcode;
TclStoreInt1AtPtr(opcode,
envPtr->codeStart
+ bbPtr->jumpOffset);
motion += 3;
bbPtr->flags &= ~BB_JUMP1;
}
}
}
/*
* If the basic block references a jump table, that doesn't
* affect the code locations, but resolve the labels now, and
* store basic block pointers in the jumptable hash.
*/
if (bbPtr->flags & BB_JUMPTABLE) {
if (CheckJumpTableLabels(assemEnvPtr, bbPtr) != TCL_OK) {
return TCL_ERROR;
}
}
}
*mustMove += motion;
} while (motion != 0);
return TCL_OK;
}
/*
*-----------------------------------------------------------------------------
*
* CheckJumpTableLabels --
*
* Make sure that all the labels in a jump table are defined.
*
* Results:
* Returns TCL_OK if they are, TCL_ERROR if they aren't.
*
*-----------------------------------------------------------------------------
*/
static int
CheckJumpTableLabels(AssemblyEnv* assemEnvPtr,
/* Assembly environment */
BasicBlock* bbPtr)
/* Basic block that ends in a jump table */
{
Tcl_HashTable* symHash = &bbPtr->jtPtr->hashTable;
/* Hash table with the symbols */
Tcl_HashSearch search; /* Hash table iterator */
Tcl_HashEntry* symEntryPtr; /* Hash entry for the symbols */
Tcl_Obj* symbolObj; /* Jump target */
Tcl_HashEntry* valEntryPtr; /* Hash entry for the resolutions */
/* Look up every jump target in the jump hash */
/* fprintf(stderr, "check jump table labels %p {\n", bbPtr); */
for (symEntryPtr = Tcl_FirstHashEntry(symHash, &search);
symEntryPtr != NULL;
symEntryPtr = Tcl_NextHashEntry(&search)) {
symbolObj = (Tcl_Obj*) Tcl_GetHashValue(symEntryPtr);
valEntryPtr = Tcl_FindHashEntry(&assemEnvPtr->labelHash,
Tcl_GetString(symbolObj));
/* fprintf(stderr, " %s -> %s (%d)\n",
(char*)Tcl_GetHashKey(symHash, symEntryPtr),
Tcl_GetString(symbolObj),
(valEntryPtr != NULL)); fflush(stderr); */
if (valEntryPtr == NULL) {
ReportUndefinedLabel(assemEnvPtr, bbPtr, symbolObj);
return TCL_ERROR;
}
}
/* fprintf(stderr, "}\n"); fflush(stderr); */
return TCL_OK;
}
/*
*-----------------------------------------------------------------------------
*
* ReportUndefinedLabel --
*
* Report that a basic block refers to an undefined jump label
*
* Side effects:
* Stores an error message, error code, and line number information in
* the assembler's Tcl interpreter.
*
*-----------------------------------------------------------------------------
*/
static void
ReportUndefinedLabel(AssemblyEnv* assemEnvPtr,
/* Assembler environment */
BasicBlock* bbPtr,
/* Basic block that contains the
* undefined label */
Tcl_Obj* jumpTarget)
/* Label of a jump target */
{
CompileEnv* envPtr = assemEnvPtr->envPtr;
/* Compilation environment */
Tcl_Interp* interp = (Tcl_Interp*) envPtr->iPtr;
/* Tcl interpreter */
Tcl_Obj* result; /* Error message */
if (assemEnvPtr->flags & TCL_EVAL_DIRECT) {
result = Tcl_NewStringObj("undefined label \"", -1);
Tcl_AppendObjToObj(result, jumpTarget);
Tcl_AppendToObj(result, "\"", -1);
Tcl_SetObjResult(interp, result);
Tcl_SetErrorCode(interp, "TCL", "ASSEM", "NOLABEL",
Tcl_GetString(jumpTarget), NULL);
Tcl_SetErrorLine(interp, bbPtr->jumpLine);
}
}
/*
*-----------------------------------------------------------------------------
*
* MoveCodeForJumps --
*
* Move bytecodes in memory to accommodate JUMP1 instructions that have
* expanded to become JUMP4's.
*
*-----------------------------------------------------------------------------
*/
static void
MoveCodeForJumps(AssemblyEnv* assemEnvPtr,
/* Assembler environment */
int mustMove) /* Number of bytes of added code */
{
CompileEnv* envPtr = assemEnvPtr->envPtr;
/* Compilation environment */
BasicBlock* bbPtr; /* Pointer to a basic block being checked */
int topOffset; /* Bytecode offset of the following
* basic block before code motion */
/*
* Make sure that there is enough space in the bytecode array to accommodate
* the expanded code.
*/
while (envPtr->codeEnd < envPtr->codeNext + mustMove) {
TclExpandCodeArray(envPtr);
}
/*
* Iterate through the bytecodes in reverse order, and move them
* upward to their new homes.
*/
topOffset = envPtr->codeNext - envPtr->codeStart;
for (bbPtr = assemEnvPtr->curr_bb; bbPtr != NULL; bbPtr = bbPtr->prevPtr) {
/* fprintf(stderr, "move code from %d to %d\n",
bbPtr->originalStartOffset, bbPtr->startOffset); fflush(stderr);
*/
memmove(envPtr->codeStart + bbPtr->startOffset,
envPtr->codeStart + bbPtr->originalStartOffset,
topOffset - bbPtr->originalStartOffset);
topOffset = bbPtr->originalStartOffset;
bbPtr->jumpOffset += (bbPtr->startOffset - bbPtr->originalStartOffset);
}
envPtr->codeNext += mustMove;
}
/*
*-----------------------------------------------------------------------------
*
* FillInJumpOffsets --
*
* Fill in the final offsets of all jump instructions once bytecode
* locations have been completely determined.
*
*-----------------------------------------------------------------------------
*/
static void
FillInJumpOffsets(AssemblyEnv* assemEnvPtr)
{
CompileEnv* envPtr = assemEnvPtr->envPtr;
/* Compilation environment */
BasicBlock* bbPtr; /* Pointer to a basic block being checked */
Tcl_HashEntry* entry; /* Hashtable entry for a jump target label */
BasicBlock* jumpTarget; /* Basic block where a jump goes */
int fromOffset; /* Bytecode location of a jump instruction */
int targetOffset; /* Bytecode location of a jump instruction's
* target */
for (bbPtr = assemEnvPtr->head_bb;
bbPtr != NULL;
bbPtr = bbPtr->successor1) {
if (bbPtr->jumpTarget != NULL) {
entry = Tcl_FindHashEntry(&assemEnvPtr->labelHash,
Tcl_GetString(bbPtr->jumpTarget));
jumpTarget = (BasicBlock*) Tcl_GetHashValue(entry);
fromOffset = bbPtr->jumpOffset;
targetOffset = jumpTarget->startOffset;
if (bbPtr->flags & BB_JUMP1) {
TclStoreInt1AtPtr(targetOffset - fromOffset,
envPtr->codeStart + fromOffset + 1);
} else {
TclStoreInt4AtPtr(targetOffset - fromOffset,
envPtr->codeStart + fromOffset + 1);
}
}
if (bbPtr->flags & BB_JUMPTABLE) {
ResolveJumpTableTargets(assemEnvPtr, bbPtr);
}
}
}
/*
*-----------------------------------------------------------------------------
*
* ResolveJumpTableTargets --
*
* Puts bytecode addresses for the targets of a jumptable into the
* table
*
* Results:
* Returns TCL_OK if they are, TCL_ERROR if they aren't.
*
*-----------------------------------------------------------------------------
*/
static void
ResolveJumpTableTargets(AssemblyEnv* assemEnvPtr,
/* Assembly environment */
BasicBlock* bbPtr)
/* Basic block that ends in a jump table */
{
CompileEnv* envPtr = assemEnvPtr->envPtr;;
/* Compilation environment */
Tcl_HashTable* symHash = &bbPtr->jtPtr->hashTable;
/* Hash table with the symbols */
Tcl_HashSearch search; /* Hash table iterator */
Tcl_HashEntry* symEntryPtr; /* Hash entry for the symbols */
Tcl_Obj* symbolObj; /* Jump target */
Tcl_HashEntry* valEntryPtr; /* Hash entry for the resolutions */
int auxDataIndex; /* Index of the auxdata */
JumptableInfo* realJumpTablePtr;
/* Jump table in the actual code */
Tcl_HashTable* realJumpHashPtr;
/* Jump table hash in the actual code */
Tcl_HashEntry* realJumpEntryPtr;
/* Entry in the jump table hash in
* the actual code */
BasicBlock* jumpTargetBBPtr;
/* Basic block that the jump proceeds to */
int junk;
auxDataIndex = TclGetInt4AtPtr(envPtr->codeStart + bbPtr->jumpOffset + 1);
/* fprintf(stderr, "bbPtr = %p jumpOffset = %d auxDataIndex = %d\n",
bbPtr, bbPtr->jumpOffset, auxDataIndex); */
realJumpTablePtr = (JumptableInfo*)
envPtr->auxDataArrayPtr[auxDataIndex].clientData;
realJumpHashPtr = &(realJumpTablePtr->hashTable);
/* Look up every jump target in the jump hash */
/* fprintf(stderr, "resolve jump table {\n"); fflush(stderr); */
for (symEntryPtr = Tcl_FirstHashEntry(symHash, &search);
symEntryPtr != NULL;
symEntryPtr = Tcl_NextHashEntry(&search)) {
symbolObj = (Tcl_Obj*) Tcl_GetHashValue(symEntryPtr);
/* fprintf(stderr, " symbol %s\n", Tcl_GetString(symbolObj)); */
valEntryPtr = Tcl_FindHashEntry(&assemEnvPtr->labelHash,
Tcl_GetString(symbolObj));
jumpTargetBBPtr = (BasicBlock*) Tcl_GetHashValue(valEntryPtr);
realJumpEntryPtr =
Tcl_CreateHashEntry(realJumpHashPtr,
Tcl_GetHashKey(symHash, symEntryPtr),
&junk);
/* fprintf(stderr, " %s -> %s -> bb %p (pc %d) hash entry %p\n",
(char*)Tcl_GetHashKey(symHash, symEntryPtr),
Tcl_GetString(symbolObj), jumpTargetBBPtr,
jumpTargetBBPtr->startOffset, realJumpEntryPtr);
fflush(stderr); */
Tcl_SetHashValue(realJumpEntryPtr,
(ClientData) (jumpTargetBBPtr->startOffset
- bbPtr->jumpOffset));
}
/* fprintf(stderr, "}\n"); fflush(stderr); */
}
/*
*-----------------------------------------------------------------------------
*
* CheckForThrowInWrongContext --
*
* Verify that no beginCatch/endCatch sequence can throw an exception
* after an original exception is caught and before its exception
* context is removed from the stack.
*
* Results:
* Returns a standard Tcl result.
*
* Side effects:
* Stores an appropriate error message in the interpreter as needed.
*
*-----------------------------------------------------------------------------
*/
static int
CheckForThrowInWrongContext(AssemblyEnv* assemEnvPtr)
/* Assembler environment */
{
BasicBlock* blockPtr; /* Current basic block */
/*
* Walk through the basic blocks in turn, checking all the ones
* that have caught an exception and not disposed of it properly.
*/
for (blockPtr = assemEnvPtr->head_bb;
blockPtr != NULL;
blockPtr = blockPtr->successor1) {
if (blockPtr->catchState == BBCS_CAUGHT) {
/* Walk through the instructions in the basic block */
if (CheckNonThrowingBlock(assemEnvPtr, blockPtr) != TCL_OK) {
return TCL_ERROR;
}
}
}
return TCL_OK;
}
/*
*-----------------------------------------------------------------------------
*
* CheckNonThrowingBlock --
*
* Check that a basic block cannot throw an exception.
*
* Results:
* Returns TCL_ERROR if the block cannot be proven to be nonthrowing.
*
* Side effects:
* Stashes an error message in the interpreter result.
*
*-----------------------------------------------------------------------------
*/
static int
CheckNonThrowingBlock(AssemblyEnv* assemEnvPtr,
/* Assembler environment */
BasicBlock* blockPtr)
/* Basic block where exceptions are
* not allowed */
{
CompileEnv* envPtr = assemEnvPtr->envPtr;
/* Compilation environment */
Tcl_Interp* interp = (Tcl_Interp*) envPtr->iPtr;
/* Tcl interpreter */
BasicBlock* nextPtr; /* Pointer to the succeeding basic block */
int offset; /* Bytecode offset of the current instruction */
int bound; /* Bytecode offset following the last
* instruction of the block. */
unsigned char opcode; /* Current bytecode instruction */
Tcl_Obj* retval; /* Error message */
/* Determine where in the code array the basic block ends */
nextPtr = blockPtr->successor1;
if (nextPtr == NULL) {
bound = envPtr->codeNext - envPtr->codeStart;
} else {
bound = nextPtr->startOffset;
}
/* Walk through the instructions of the block */
offset = blockPtr->startOffset;
while (offset < bound) {
/* Determine whether an instruction is nonthrowing */
opcode = (envPtr->codeStart)[offset];
if (BytecodeMightThrow(opcode)) {
/* Report an error for a throw in the wrong context */
if (assemEnvPtr->flags & TCL_EVAL_DIRECT) {
retval = Tcl_NewStringObj("\"", -1);
Tcl_AppendToObj(retval, tclInstructionTable[opcode].name,
-1);
Tcl_AppendToObj(retval, "\" instruction may not appear in "
"a context where an exception has been "
"caught and not disposed of.", -1);
Tcl_SetErrorCode(interp, "TCL", "ASSEM", "BADTHROW", NULL);
Tcl_SetObjResult(interp, retval);
AddBasicBlockRangeToErrorInfo(assemEnvPtr, blockPtr);
}
return TCL_ERROR;
}
offset += tclInstructionTable[opcode].numBytes;
}
return TCL_OK;
}
/*
*-----------------------------------------------------------------------------
*
* BytecodeMightThrow --
*
* Tests if a given bytecode instruction might throw an exception.
*
* Results:
* Returns 1 if the bytecode might throw an exception, 0 if the
* instruction is known never to throw.
*
*-----------------------------------------------------------------------------
*/
static int
BytecodeMightThrow(unsigned char opcode)
{
/* Binary search on the non-throwing bytecode list */
int min = 0;
int max = sizeof(NonThrowingByteCodes)-1;
int mid;
unsigned char c;
while (max >= min) {
mid = (min + max) / 2;
c = NonThrowingByteCodes[mid];
if (opcode < c) {
max = mid-1;
} else if (opcode > c) {
min = mid+1;
} else {
/* Opcode is nonthrowing */
return 0;
}
}
return 1;
}
/*
*-----------------------------------------------------------------------------
*
* CheckStack --
*
* Audit stack usage in a block of assembly code.
*
* Results:
* Returns a standard Tcl result.
*
* Side effects:
* Updates stack depth on entry for all basic blocks in the flowgraph.
* Calculates the max stack depth used in the program, and updates the
* compilation environment to reflect it.
*
*-----------------------------------------------------------------------------
*/
static int
CheckStack(AssemblyEnv* assemEnvPtr)
/* Assembly environment */
{
CompileEnv* envPtr = assemEnvPtr->envPtr;
/* Compilation environment */
int maxDepth; /* Maximum stack depth overall */
/* Checking the head block will check all the other blocks recursively. */
assemEnvPtr->maxDepth = 0;
if (StackCheckBasicBlock(assemEnvPtr,
assemEnvPtr->head_bb, NULL, 0) == TCL_ERROR) {
return TCL_ERROR;
}
/* Post the max stack depth back to the compilation environment */
maxDepth = assemEnvPtr->maxDepth + envPtr->currStackDepth;
if (maxDepth > envPtr->maxStackDepth) {
envPtr->maxStackDepth = maxDepth;
}
/* If the exit is reachable, make sure that the program exits with
* 1 operand on the stack. */
if (StackCheckExit(assemEnvPtr) != TCL_OK) {
return TCL_ERROR;
}
/* Reset the visited state on all basic blocks */
ResetVisitedBasicBlocks(assemEnvPtr);
return TCL_OK;
}
/*
*-----------------------------------------------------------------------------
*
* StackCheckBasicBlock --
*
* Checks stack consumption for a basic block (and recursively for
* its successors).
*
* Results:
* Returns a standard Tcl result.
*
* Side effects:
* Updates initial stack depth for the basic block and its
* successors. (Final and maximum stack depth are relative to
* initial, and are not touched).
*
* This procedure eventually checks, for the entire flow graph, whether
* stack balance is consistent. It is an error for a given basic block
* to be reachable along multiple flow paths with different stack depths.
*
*-----------------------------------------------------------------------------
*/
static int
StackCheckBasicBlock(AssemblyEnv* assemEnvPtr,
/* Assembly environment */
BasicBlock* blockPtr,
/* Pointer to the basic block being checked */
BasicBlock* predecessor,
/* Pointer to the block that passed control
* to this one. */
int initialStackDepth)
/* Stack depth on entry to the block */
{
CompileEnv* envPtr = assemEnvPtr->envPtr;
/* Compilation environment */
Tcl_Interp* interp = (Tcl_Interp*) envPtr->iPtr;
/* Tcl interpreter */
BasicBlock* jumpTarget; /* Basic block where a jump goes */
int stackDepth; /* Current stack depth */
int maxDepth; /* Maximum stack depth so far */
int result; /* Tcl status return */
Tcl_HashSearch jtSearch; /* Search structure for the jump table */
Tcl_HashEntry* jtEntry; /* Hash entry in the jump table */
Tcl_Obj* targetLabel; /* Target label from the jump table */
Tcl_HashEntry* entry; /* Hash entry in the label table */
if (blockPtr->flags & BB_VISITED) {
/*
* If the block is already visited, check stack depth for consistency
* among the paths that reach it.
*/
if (blockPtr->initialStackDepth != initialStackDepth) {
if (assemEnvPtr->flags & TCL_EVAL_DIRECT) {
Tcl_SetObjResult(interp,
Tcl_NewStringObj("inconsistent stack depths "
"on two execution paths",
-1));
/* TODO - add execution trace of both paths */
Tcl_SetErrorLine(interp, blockPtr->startLine);
Tcl_SetErrorCode(interp, "TCL", "ASSEM", "BADSTACK", NULL);
}
return TCL_ERROR;
} else {
return TCL_OK;
}
}
/*
* If the block is not already visited, set the 'predecessor'
* link to indicate how control got to it. Set the initial stack
* depth to the current stack depth in the flow of control.
*/
blockPtr->flags |= BB_VISITED;
blockPtr->predecessor = predecessor;
blockPtr->initialStackDepth = initialStackDepth;
/*
* Calculate minimum stack depth, and flag an error if the block
* underflows the stack.
*/
if (initialStackDepth + blockPtr->minStackDepth < 0) {
if (assemEnvPtr->flags & TCL_EVAL_DIRECT) {
Tcl_SetObjResult(interp,
Tcl_NewStringObj("stack underflow", -1));
Tcl_SetErrorCode(interp, "TCL", "ASSEM", "BADSTACK", NULL);
AddBasicBlockRangeToErrorInfo(assemEnvPtr, blockPtr);
Tcl_SetErrorLine(interp, blockPtr->startLine);
}
return TCL_ERROR;
}
/*
* Make sure that the block doesn't try to pop below the stack level
* of an enclosing catch.
*/
if (blockPtr->enclosingCatch != 0
&& initialStackDepth + blockPtr->minStackDepth
< (blockPtr->enclosingCatch->initialStackDepth
+ blockPtr->enclosingCatch->finalStackDepth)) {
if (assemEnvPtr->flags & TCL_EVAL_DIRECT) {
Tcl_SetObjResult(interp,
Tcl_NewStringObj("code pops stack below level of"
" enclosing catch", -1));
Tcl_SetErrorCode(interp, "TCL", "ASSEM", "BADSTACKINCATCH", -1);
AddBasicBlockRangeToErrorInfo(assemEnvPtr, blockPtr);
Tcl_SetErrorLine(interp, blockPtr->startLine);
}
return TCL_ERROR;
}
/*
* Update maximum stgack depth.
*/
maxDepth = initialStackDepth + blockPtr->maxStackDepth;
if (maxDepth > assemEnvPtr->maxDepth) {
assemEnvPtr->maxDepth = maxDepth;
}
/*
* Calculate stack depth on exit from the block, and invoke this
* procedure recursively to check successor blocks
*/
stackDepth = initialStackDepth + blockPtr->finalStackDepth;
result = TCL_OK;
if (blockPtr->flags & BB_FALLTHRU) {
result = StackCheckBasicBlock(assemEnvPtr, blockPtr->successor1,
blockPtr, stackDepth);
}
if (result == TCL_OK && blockPtr->jumpTarget != NULL) {
entry = Tcl_FindHashEntry(&assemEnvPtr->labelHash,
Tcl_GetString(blockPtr->jumpTarget));
jumpTarget = (BasicBlock*) Tcl_GetHashValue(entry);
result = StackCheckBasicBlock(assemEnvPtr, jumpTarget,
blockPtr, stackDepth);
}
/* All blocks referenced in a jump table are successors */
if (blockPtr->flags & BB_JUMPTABLE) {
for (jtEntry = Tcl_FirstHashEntry(&(blockPtr->jtPtr->hashTable),
&jtSearch);
result == TCL_OK && jtEntry != NULL;
jtEntry = Tcl_NextHashEntry(&jtSearch)) {
targetLabel = (Tcl_Obj*) Tcl_GetHashValue(jtEntry);
entry = Tcl_FindHashEntry(&assemEnvPtr->labelHash,
Tcl_GetString(targetLabel));
jumpTarget = (BasicBlock*) Tcl_GetHashValue(entry);
result = StackCheckBasicBlock(assemEnvPtr, jumpTarget,
blockPtr, stackDepth);
}
}
return result;
}
/*
*-----------------------------------------------------------------------------
*
* StackCheckExit --
*
* Makes sure that the net stack effect of an entire assembly language
* script is to push 1 result.
*
* Results:
* Returns a standard Tcl result, with an error message in the interpreter
* result if the stack is wrong.
*
* Side effects:
* If the assembly code had a net stack effect of zero, emits code
* to the concluding block to push a null result. In any case,
* updates the stack depth in the compile environment to reflect
* the net effect of the assembly code.
*
*-----------------------------------------------------------------------------
*/
static int
StackCheckExit(AssemblyEnv* assemEnvPtr)
/* Assembler environment */
{
CompileEnv* envPtr = assemEnvPtr->envPtr;
/* Compilation environment */
Tcl_Interp* interp = (Tcl_Interp*) envPtr->iPtr;
/* Tcl interpreter */
int depth; /* Net stack effect */
int litIndex; /* Index in the literal pool of the empty
* string */
Tcl_Obj* depthObj; /* Net stack effect for an error message */
Tcl_Obj* resultObj; /* Error message from this procedure */
BasicBlock* curr_bb = assemEnvPtr->curr_bb;
/* Final basic block in the assembly */
/*
* Don't perform these checks if execution doesn't reach the
* exit (either because of an infinite loop or because the only
* return is from the middle.
*/
if (curr_bb->flags & BB_VISITED) {
/* Exit with no operands; push an empty one. */
depth = curr_bb->finalStackDepth + curr_bb->initialStackDepth;
if (depth == 0) {
/* Emit a 'push' of the empty literal */
litIndex = TclRegisterNewLiteral(envPtr, "", 0);
/* Assumes that 'push' is at slot 0 in TalInstructionTable */
BBEmitInst1or4(assemEnvPtr, 0, litIndex, 0);
++depth;
}
/* Exit with unbalanced stack */
if (depth != 1) {
if (assemEnvPtr->flags & TCL_EVAL_DIRECT) {
depthObj = Tcl_NewIntObj(depth);
Tcl_IncrRefCount(depthObj);
resultObj = Tcl_NewStringObj("stack is unbalanced on exit "
"from the code (depth=", -1);
Tcl_AppendObjToObj(resultObj, depthObj);
Tcl_DecrRefCount(depthObj);
Tcl_AppendToObj(resultObj, ")", -1);
Tcl_SetObjResult(interp, resultObj);
Tcl_SetErrorCode(interp, "TCL", "ASSEM", "BADSTACK", NULL);
}
return TCL_ERROR;
}
/* Record stack usage */
envPtr->currStackDepth += depth;
}
return TCL_OK;
}
/*
*-----------------------------------------------------------------------------
*
* ProcessCatches --
*
* First pass of 'catch' processing.
*
* Results:
* Returns a standard Tcl result, with an appropriate error message
* if the result is TCL_ERROR.
*
* Side effects:
* Labels all basic blocks with their enclosing catches.
*
*-----------------------------------------------------------------------------
*/
static int
ProcessCatches(AssemblyEnv* assemEnvPtr)
/* Assembler environment */
{
BasicBlock* blockPtr; /* Pointer to a basic block */
/*
* Clear the catch state of all basic blocks
*/
for (blockPtr = assemEnvPtr->head_bb;
blockPtr != NULL;
blockPtr = blockPtr->successor1) {
blockPtr->catchState = BBCS_UNKNOWN;
blockPtr->enclosingCatch = NULL;
}
/*
* Start the check recursively from the first basic block, which
* is outside any exception context
*/
if (ProcessCatchesInBasicBlock(assemEnvPtr, assemEnvPtr->head_bb,
NULL, BBCS_NONE, 0) != TCL_OK) {
return TCL_ERROR;
}
/* Check for unclosed catch on exit */
if (CheckForUnclosedCatches(assemEnvPtr) != TCL_OK) {
return TCL_ERROR;
}
/* Now there's enough information to build the exception ranges. */
if (BuildExceptionRanges(assemEnvPtr) != TCL_OK) {
return TCL_ERROR;
}
/* Finally, restore any exception ranges from embedded scripts */
RestoreEmbeddedExceptionRanges(assemEnvPtr);
return TCL_OK;
}
/*
*-----------------------------------------------------------------------------
*
* ProcessCatchesInBasicBlock --
*
* First-pass catch processing for one basic block.
*
* Results:
* Returns a standard Tcl result, with error message in the interpreter
* result if an error occurs.
*
* This procedure checks consistency of the exception context through the
* assembler program, and records the enclosing 'catch' for every basic
* block.
*
*-----------------------------------------------------------------------------
*/
static int
ProcessCatchesInBasicBlock(AssemblyEnv* assemEnvPtr,
/* Assembler environment */
BasicBlock* bbPtr,
/* Basic block being processed */
BasicBlock* enclosing,
/* Start basic block of the enclosing catch */
enum BasicBlockCatchState state,
/* BBCS_NONE, BBCS_INCATCH, or BBCS_CAUGHT */
int catchDepth)
/* Depth of nesting of catches */
{
CompileEnv* envPtr = assemEnvPtr->envPtr;
/* Compilation environment */
Tcl_Interp* interp = (Tcl_Interp*) envPtr->iPtr;
/* Tcl interpreter */
int result; /* Return value from this procedure */
BasicBlock* fallThruEnclosing;
/* Enclosing catch if execution falls thru */
enum BasicBlockCatchState fallThruState;
/* Catch state of the successor block */
BasicBlock* jumpEnclosing;
/* Enclosing catch if execution goes to
* jump target */
enum BasicBlockCatchState jumpState;
/* Catch state of the jump target */
int changed = 0; /* Flag == 1 iff successor blocks need
* to be checked because the state of this
* block has changed. */
BasicBlock* jumpTarget; /* Basic block where a jump goes */
Tcl_HashSearch jtSearch; /* Hash search control for a jumptable */
Tcl_HashEntry* jtEntry; /* Entry in a jumptable */
Tcl_Obj* targetLabel; /* Target label from a jumptable */
Tcl_HashEntry* entry; /* Entry from the label table */
/*
* Update the state of the current block, checking for consistency.
* Set 'changed' to 1 if the state changes and successor blocks
* need to be rechecked.
*/
if (bbPtr->catchState == BBCS_UNKNOWN) {
bbPtr->enclosingCatch = enclosing;
} else if (bbPtr->enclosingCatch != enclosing) {
if (assemEnvPtr->flags & TCL_EVAL_DIRECT) {
Tcl_SetObjResult(interp,
Tcl_NewStringObj("execution reaches an "
"instruction in "
"inconsistent exception contexts",
-1));
Tcl_SetErrorLine(interp, bbPtr->startLine);
Tcl_SetErrorCode(interp, "TCL", "ASSEM", "BADCATCH", NULL);
}
return TCL_ERROR;
}
if (state > bbPtr->catchState) {
bbPtr->catchState = state;
changed = 1;
}
/*
* If this block has been visited before, and its state hasn't
* changed, we're done with it for now.
*/
if (!changed) {
return TCL_OK;
}
bbPtr->catchDepth = catchDepth;
/*
* Determine enclosing catch and 'caught' state for the fallthrough
* and the jump target. Default for both is the state of the current block.
*/
fallThruEnclosing = enclosing;
fallThruState = state;
jumpEnclosing = enclosing;
jumpState = state;
/* TODO: Make sure that the test cases include validating
* that a natural loop can't include 'beginCatch' or 'endCatch' */
if (bbPtr->flags & BB_BEGINCATCH) {
/*
* If the block begins a catch, the state for the successor is
* 'in catch'. The jump target is the exception exit, and the state
* of the jump target is 'caught.'
*/
fallThruEnclosing = bbPtr;
fallThruState = BBCS_INCATCH;
jumpEnclosing = bbPtr;
jumpState = BBCS_CAUGHT;
++catchDepth;
}
if (bbPtr->flags & BB_ENDCATCH) {
/*
* If the block ends a catch, the state for the successor is
* whatever the state was on entry to the catch.
*/
if (enclosing == NULL) {
if (assemEnvPtr->flags & TCL_EVAL_DIRECT) {
Tcl_SetObjResult(interp,
Tcl_NewStringObj("endCatch without a "
"corresponding beginCatch",
-1));
Tcl_SetErrorLine(interp, bbPtr->startLine);
Tcl_SetErrorCode(interp, "TCL", "ASSEM", "BADENDCATCH", NULL);
}
return TCL_ERROR;
}
fallThruEnclosing = enclosing->enclosingCatch;
fallThruState = enclosing->catchState;
--catchDepth;
}
/*
* Visit any successor blocks with the appropriate exception context
*/
result = TCL_OK;
if (bbPtr->flags & BB_FALLTHRU) {
result = ProcessCatchesInBasicBlock(assemEnvPtr, bbPtr->successor1,
fallThruEnclosing, fallThruState,
catchDepth);
}
if (result == TCL_OK && bbPtr->jumpTarget != NULL) {
entry = Tcl_FindHashEntry(&assemEnvPtr->labelHash,
Tcl_GetString(bbPtr->jumpTarget));
jumpTarget = (BasicBlock*) Tcl_GetHashValue(entry);
result = ProcessCatchesInBasicBlock(assemEnvPtr, jumpTarget,
jumpEnclosing, jumpState,
catchDepth);
}
/* All blocks referenced in a jump table are successors */
if (bbPtr->flags & BB_JUMPTABLE) {
for (jtEntry = Tcl_FirstHashEntry(&(bbPtr->jtPtr->hashTable),
&jtSearch);
result == TCL_OK && jtEntry != NULL;
jtEntry = Tcl_NextHashEntry(&jtSearch)) {
targetLabel = (Tcl_Obj*) Tcl_GetHashValue(jtEntry);
entry = Tcl_FindHashEntry(&assemEnvPtr->labelHash,
Tcl_GetString(targetLabel));
jumpTarget = (BasicBlock*) Tcl_GetHashValue(entry);
result = ProcessCatchesInBasicBlock(assemEnvPtr, jumpTarget,
jumpEnclosing, jumpState,
catchDepth);
}
}
return result;
}
/*
*-----------------------------------------------------------------------------
*
* CheckForUnclosedCatches --
*
* Checks that a sequence of assembly code has no unclosed catches
* on exit.
*
* Results:
* Returns a standard Tcl result, with an error message for unclosed
* catches.
*
*-----------------------------------------------------------------------------
*/
static int
CheckForUnclosedCatches(AssemblyEnv* assemEnvPtr)
{
CompileEnv* envPtr = assemEnvPtr->envPtr;
/* Compilation environment */
Tcl_Interp* interp = (Tcl_Interp*) envPtr->iPtr;
/* Tcl interpreter */
if (assemEnvPtr->curr_bb->catchState >= BBCS_INCATCH) {
if (assemEnvPtr->flags & TCL_EVAL_DIRECT) {
Tcl_SetObjResult(interp, Tcl_NewStringObj("catch still active on "
"exit from assembly "
"code", -1));
Tcl_SetErrorLine(interp,
assemEnvPtr->curr_bb->enclosingCatch->startLine);
Tcl_SetErrorCode(interp, "TCL", "ASSEM", "UNCLOSEDCATCH", NULL);
}
return TCL_ERROR;
}
return TCL_OK;
}
/*
*-----------------------------------------------------------------------------
*
* BuildExceptionRanges --
*
* Walks through the assembly code and builds exception ranges for
* the catches embedded therein.
*
* Results:
* Returns a standard Tcl result with an error message in the interpreter
* if anything is unsuccessful.
*
* Side effects:
* Each contiguous block of code with a given catch exit is assigned
* an exception range at the appropriate level.
* Exception ranges in embedded blocks have their levels corrected
* and collated into the table.
* Blocks that end with 'beginCatch' are associated with the innermost
* exception range of the following block.
*
*-----------------------------------------------------------------------------
*/
static int
BuildExceptionRanges(AssemblyEnv* assemEnvPtr)
/* Assembler environment */
{
CompileEnv* envPtr = assemEnvPtr->envPtr;
/* Compilation environment */
BasicBlock* bbPtr; /* Current basic block */
BasicBlock* prevPtr = NULL; /* Previous basic block */
int catchDepth = 0; /* Current catch depth */
int maxCatchDepth= 0; /* Maximum catch depth in the program */
BasicBlock** catches; /* Stack of catches in progress */
int* catchIndices; /* Indices of the exception ranges
* of catches in progress */
int i;
/*
* Determine the max catch depth for the entire assembly script
* (excluding embedded eval's and expr's, which will be handled later).
*/
for (bbPtr = assemEnvPtr->head_bb; bbPtr != NULL; bbPtr=bbPtr->successor1) {
if (bbPtr->catchDepth > maxCatchDepth) {
maxCatchDepth = bbPtr->catchDepth;
}
}
/* Allocate memory for a stack of active catches */
catches = (BasicBlock**) ckalloc(maxCatchDepth * sizeof(BasicBlock*));
catchIndices = (int*) ckalloc(maxCatchDepth * sizeof(int));
for (i = 0; i < maxCatchDepth; ++i) {
catches[i] = NULL;
catchIndices[i] = -1;
}
/* Walk through the basic blocks and manage exception ranges. */
for (bbPtr = assemEnvPtr->head_bb; bbPtr != NULL; bbPtr=bbPtr->successor1) {
UnstackExpiredCatches(envPtr, bbPtr, catchDepth,
catches, catchIndices);
LookForFreshCatches(bbPtr, catches);
StackFreshCatches(assemEnvPtr, bbPtr, catchDepth,
catches, catchIndices);
/* If the last block was a 'begin catch', fill in the exception range */
catchDepth = bbPtr->catchDepth;
if (prevPtr != NULL
&& (prevPtr->flags & BB_BEGINCATCH)) {
TclStoreInt4AtPtr(catchIndices[catchDepth-1],
envPtr->codeStart + bbPtr->startOffset - 4);
}
prevPtr = bbPtr;
}
if (catchDepth != 0) {
Tcl_Panic("unclosed catch at end of code in "
"tclAssembly.c:BuildExceptionRanges, can't happen");
}
return TCL_OK;
}
/*
*-----------------------------------------------------------------------------
*
* UnstackExpiredCatches --
*
* Unstacks and closes the exception ranges for any catch contexts that
* were active in the previous basic block but are inactive in the
* current one.
*
*-----------------------------------------------------------------------------
*/
static void
UnstackExpiredCatches(CompileEnv* envPtr,
/* Compilation environment */
BasicBlock* bbPtr,
/* Basic block being processed */
int catchDepth,
/* Depth of nesting of catches prior to
* entry to this block */
BasicBlock** catches,
/* Array of catch contexts */
int* catchIndices)
/* Indices of the exception ranges
* corresponding to the catch contexts */
{
ExceptionRange* range; /* Exception range for a specific catch */
BasicBlock* catch; /* Catch block being examined */
BasicBlockCatchState catchState;
/* State of the code relative to
* the catch block being examined
* ("in catch" or "caught") */
/*
* Unstack any catches that are deeper than the nesting level of
* the basic block being entered.
*/
while (catchDepth > bbPtr->catchDepth) {
--catchDepth;
range = envPtr->exceptArrayPtr + catchIndices[catchDepth];
range->numCodeBytes = bbPtr->startOffset - range->codeOffset;
catches[catchDepth] = NULL;
catchIndices[catchDepth] = -1;
}
/*
* Unstack any catches that don't match the basic block being entered,
* either because they are no longer part of the context, or because
* the context has changed from INCATCH to CAUGHT.
*/
catchState = bbPtr->catchState;
catch = bbPtr->enclosingCatch;
while (catchDepth > 0) {
--catchDepth;
if (catches[catchDepth] != NULL) {
if (catches[catchDepth] != catch
|| catchState >= BBCS_CAUGHT) {
range = envPtr->exceptArrayPtr + catchIndices[catchDepth];
range->numCodeBytes = bbPtr->startOffset - range->codeOffset;
catches[catchDepth] = NULL;
catchIndices[catchDepth] = -1;
}
catchState = catch->catchState;
catch = catch->enclosingCatch;
}
}
}
/*
*-----------------------------------------------------------------------------
*
* LookForFreshCatches --
*
* Determines whether a basic block being entered needs any exception
* ranges that are not already stacked.
*
* Does not create the ranges: this procedure iterates from the innermost
* catch outward, but exception ranges must be created from the outermost
* catch inward.
*
*-----------------------------------------------------------------------------
*/
static void
LookForFreshCatches(BasicBlock* bbPtr,
/* Basic block being entered */
BasicBlock** catches)
/* Array of catch contexts that are
* already entered */
{
BasicBlockCatchState catchState;
/* State ("in catch" or "caught" of
* the current catch. */
BasicBlock* catch; /* Current enclosing catch */
int catchDepth; /* Nesting depth of the current catch */
catchState = bbPtr->catchState;
catch = bbPtr->enclosingCatch;
catchDepth = bbPtr->catchDepth;
while (catchDepth > 0) {
--catchDepth;
if (catches[catchDepth] != catch && catchState < BBCS_CAUGHT) {
catches[catchDepth] = catch;
}
catchState = catch->catchState;
catch = catch->enclosingCatch;
}
}
/*
*-----------------------------------------------------------------------------\ *
* StackFreshCatches --
*
* Make ExceptionRange records for any catches that are in the
* basic block being entered and were not in the previous basic block.
*
*-----------------------------------------------------------------------------
*/
static void
StackFreshCatches(AssemblyEnv* assemEnvPtr,
/* Assembly environment */
BasicBlock* bbPtr,
/* Basic block being processed */
int catchDepth,
/* Depth of nesting of catches prior to
* entry to this block */
BasicBlock** catches,
/* Array of catch contexts */
int* catchIndices)
/* Indices of the exception ranges
* corresponding to the catch contexts */
{
CompileEnv* envPtr = assemEnvPtr->envPtr;
/* Compilation environment */
ExceptionRange* range; /* Exception range for a specific catch */
BasicBlock* catch; /* Catch block being examined */
BasicBlock* errorExit; /* Error exit from the catch block */
Tcl_HashEntry* entryPtr;
catchDepth = 0;
/*
* Iterate through the enclosing catch blocks from the outside in,
* looking for ones that don't have exception ranges (and are uncaught)
*/
for (catchDepth = 0; catchDepth < bbPtr->catchDepth; ++catchDepth) {
if (catchIndices[catchDepth] == -1 && catches[catchDepth] != NULL) {
/* Create an exception range for a block that needs one. */
catch = catches[catchDepth];
catchIndices[catchDepth] =
TclCreateExceptRange(CATCH_EXCEPTION_RANGE, envPtr);
range = envPtr->exceptArrayPtr + catchIndices[catchDepth];
range->nestingLevel = envPtr->exceptDepth + catchDepth;
envPtr->maxExceptDepth =
TclMax(range->nestingLevel + 1, envPtr->maxExceptDepth);
range->codeOffset = bbPtr->startOffset;
if ((entryPtr =
Tcl_FindHashEntry(&assemEnvPtr->labelHash,
Tcl_GetString(catch->jumpTarget)))
== NULL) {
Tcl_Panic("undefined label in tclAssembly.c:"
"BuildExceptionRanges, can't happen");
} else {
errorExit = (BasicBlock*) Tcl_GetHashValue(entryPtr);
range->catchOffset = errorExit->startOffset;
}
}
}
}
/*
*-----------------------------------------------------------------------------
*
* RestoreEmbeddedExceptionRanges --
*
* Processes an assembly script, replacing any exception ranges that
* were present in embedded code.
*
*-----------------------------------------------------------------------------
*/
static void
RestoreEmbeddedExceptionRanges(AssemblyEnv* assemEnvPtr)
/* Assembler environment */
{
CompileEnv* envPtr = assemEnvPtr->envPtr;
/* Compilation environment */
BasicBlock* bbPtr; /* Current basic block */
int rangeBase; /* Base of the foreign exception ranges
* when they are reinstalled */
int rangeIndex; /* Index of the current foreign exception
* range as reinstalled */
ExceptionRange* range; /* Current foreign exception range */
unsigned char opcode; /* Current instruction's opcode */
unsigned int catchIndex; /* Index of the exception range to which
* the current instruction refers */
int i;
/* Walk the basic blocks looking for exceptions in embedded scripts */
for (bbPtr = assemEnvPtr->head_bb;
bbPtr != NULL;
bbPtr = bbPtr->successor1) {
if (bbPtr->foreignExceptionCount != 0) {
/*
* Reinstall the embedded exceptions and track their
* nesting level
*/
rangeBase = envPtr->exceptArrayNext;
for (i = 0; i < bbPtr->foreignExceptionCount; ++i) {
range = bbPtr->foreignExceptions + i;
rangeIndex = TclCreateExceptRange(range->type, envPtr);
range->nestingLevel += envPtr->exceptDepth + bbPtr->catchDepth;
memcpy(envPtr->exceptArrayPtr + rangeIndex, range,
sizeof(ExceptionRange));
if (range->nestingLevel >= envPtr->maxExceptDepth) {
envPtr->maxExceptDepth = range->nestingLevel + 1;
}
}
/*
* Walk through the bytecode of the basic block, and relocate
* INST_BEGIN_CATCH4 instructions to the new locations
*/
i = bbPtr->startOffset;
while (i < bbPtr->successor1->startOffset) {
opcode = envPtr->codeStart[i];
if (opcode == INST_BEGIN_CATCH4) {
catchIndex = TclGetUInt4AtPtr(envPtr->codeStart + i + 1);
if (catchIndex >= bbPtr->foreignExceptionBase
&& catchIndex < (bbPtr->foreignExceptionBase +
bbPtr->foreignExceptionCount)) {
catchIndex -= bbPtr->foreignExceptionBase;
catchIndex += rangeBase;
TclStoreInt4AtPtr(catchIndex,
envPtr->codeStart + i + 1);
}
}
i += tclInstructionTable[opcode].numBytes;
}
}
}
}
/*
*-----------------------------------------------------------------------------
*
* ResetVisitedBasicBlocks --
*
* Turns off the 'visited' flag in all basic blocks at the conclusion
* of a pass.
*
*-----------------------------------------------------------------------------
*/
static void
ResetVisitedBasicBlocks(AssemblyEnv* assemEnvPtr)
{
BasicBlock* block;
for (block = assemEnvPtr->head_bb; block != NULL;
block = block->successor1) {
block->flags &= ~BB_VISITED;
}
}
/*
*-----------------------------------------------------------------------------
*
* AddBasicBlockRangeToErrorInfo --
*
* Updates the error info of the Tcl interpreter to show a given
* basic block in the code.
*
* This procedure is used to label the callstack with source location
* information when reporting an error in stack checking.
*
*-----------------------------------------------------------------------------
*/
static void
AddBasicBlockRangeToErrorInfo(AssemblyEnv* assemEnvPtr,
/* Assembly environment */
BasicBlock* bbPtr)
/* Basic block in which the error is
* found */
{
CompileEnv* envPtr = assemEnvPtr->envPtr;
/* Compilation environment */
Tcl_Interp* interp = (Tcl_Interp*) envPtr->iPtr;
/* Tcl interpreter */
Tcl_Obj* lineNo; /* Line number in the source */
Tcl_AddErrorInfo(interp, "\n in assembly code between lines ");
lineNo = Tcl_NewIntObj(bbPtr->startLine);
Tcl_IncrRefCount(lineNo);
Tcl_AddErrorInfo(interp, Tcl_GetString(lineNo));
Tcl_AddErrorInfo(interp, " and ");
if (bbPtr->successor1 != NULL) {
Tcl_SetIntObj(lineNo, bbPtr->successor1->startLine);
Tcl_AddErrorInfo(interp, Tcl_GetString(lineNo));
} else {
Tcl_AddErrorInfo(interp, "end of assembly code");
}
Tcl_DecrRefCount(lineNo);
}
/*
*-----------------------------------------------------------------------------
*
* DupAssembleCodeInternalRep --
*
* Part of the Tcl object type implementation for Tcl assembly language
* bytecode. We do not copy the bytecode intrep. Instead, we return
* without setting copyPtr->typePtr, so the copy is a plain string copy
* of the assembly source, and if it is to be used as a compiled
* expression, it will need to be reprocessed.
*
* This makes sense, because with Tcl's copy-on-write practices, the
* usual (only?) time Tcl_DuplicateObj() will be called is when the copy
* is about to be modified, which would invalidate any copied bytecode
* anyway. The only reason it might make sense to copy the bytecode is if
* we had some modifying routines that operated directly on the intrep,
* as we do for lists and dicts.
*
* Results:
* None.
*
* Side effects:
* None.
*
*-----------------------------------------------------------------------------
*/
static void
DupAssembleCodeInternalRep(
Tcl_Obj *srcPtr,
Tcl_Obj *copyPtr)
{
return;
}
/*
*-----------------------------------------------------------------------------
*
* FreeAssembleCodeInternalRep --
*
* Part of the Tcl object type implementation for Tcl expression
* bytecode. Frees the storage allocated to hold the internal rep, unless
* ref counts indicate bytecode execution is still in progress.
*
* Results:
* None.
*
* Side effects:
* May free allocated memory. Leaves objPtr untyped.
*
*-----------------------------------------------------------------------------
*/
static void
FreeAssembleCodeInternalRep(
Tcl_Obj *objPtr)
{
ByteCode *codePtr = (ByteCode *) objPtr->internalRep.otherValuePtr;
codePtr->refCount--;
if (codePtr->refCount <= 0) {
TclCleanupByteCode(codePtr);
}
objPtr->typePtr = NULL;
objPtr->internalRep.otherValuePtr = NULL;
}