riscv
/
OpenFPGA
mirror of https://github.com/lnis-uofu/OpenFPGA.git
1
0
Fork 0
Code Issues Projects Releases Wiki Activity
OpenFPGA/libs/EXTERNAL/tcl8.6.12/generic/tclAssembly.c

4351 lines
132 KiB
C
Raw Normal View History

adding Tcl interface to vpr
2022-06-07 11:15:20 -05:00
/*
* 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.
*/
/*-
*- 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, expandDrop
*- dictFirst, dictNext, dictDone
*- dictUpdateStart, dictUpdateEnd
*- jumpTable testing
*- syntax (?)
*- returnCodeBranch
*- tclooNext, tclooNextClass
*/
#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_CLOCK_READ, /* 1-byte unsigned-integer case number, in the
* range 0-3 */
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 tblIdx,
int count);
static void BBEmitInstInt1(AssemblyEnv* assemEnvPtr, int tblIdx,
int opnd, int count);
static void BBEmitInstInt4(AssemblyEnv* assemEnvPtr, int tblIdx,
int opnd, int count);
static void BBEmitInst1or4(AssemblyEnv* assemEnvPtr, int tblIdx,
int param, int count);
static void BBEmitOpcode(AssemblyEnv* assemEnvPtr, int tblIdx,
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*,
const 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);
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 */
};
/*
* Source instructions recognized in the Tcl Assembly Language (TAL)
*/
static const 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},
{"arrayExistsImm", ASSEM_LVT4, INST_ARRAY_EXISTS_IMM, 0, 1},
{"arrayExistsStk", ASSEM_1BYTE, INST_ARRAY_EXISTS_STK, 1, 1},
{"arrayMakeImm", ASSEM_LVT4, INST_ARRAY_MAKE_IMM, 0, 0},
{"arrayMakeStk", ASSEM_1BYTE, INST_ARRAY_MAKE_STK, 1, 0},
{"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},
{"clockRead", ASSEM_CLOCK_READ, INST_CLOCK_READ, 0, 1},
{"concat", ASSEM_CONCAT1, INST_STR_CONCAT1, INT_MIN,1},
{"concatStk", ASSEM_LIST, INST_CONCAT_STK, INT_MIN,1},
{"coroName", ASSEM_1BYTE, INST_COROUTINE_NAME, 0, 1},
{"currentNamespace",ASSEM_1BYTE, INST_NS_CURRENT, 0, 1},
{"dictAppend", ASSEM_LVT4, INST_DICT_APPEND, 2, 1},
{"dictExists", ASSEM_DICT_GET, INST_DICT_EXISTS, INT_MIN,1},
{"dictExpand", ASSEM_1BYTE, INST_DICT_EXPAND, 3, 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},
{"dictRecombineStk",ASSEM_1BYTE, INST_DICT_RECOMBINE_STK,3, 0},
{"dictRecombineImm",ASSEM_LVT4, INST_DICT_RECOMBINE_IMM,2, 0},
{"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_STK, 2, 1},
{"incrStkImm", ASSEM_SINT1, INST_INCR_STK_IMM, 1, 1},
{"infoLevelArgs", ASSEM_1BYTE, INST_INFO_LEVEL_ARGS, 1, 1},
{"infoLevelNumber", ASSEM_1BYTE, INST_INFO_LEVEL_NUM, 0, 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},
{"lappendList", ASSEM_LVT4, INST_LAPPEND_LIST, 1, 1},
{"lappendListArray",ASSEM_LVT4, INST_LAPPEND_LIST_ARRAY,2, 1},
{"lappendListArrayStk", ASSEM_1BYTE,INST_LAPPEND_LIST_ARRAY_STK, 3, 1},
{"lappendListStk", ASSEM_1BYTE, INST_LAPPEND_LIST_STK, 2, 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},
{"listConcat", ASSEM_1BYTE, INST_LIST_CONCAT, 2, 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_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},
{"numericType", ASSEM_1BYTE, INST_NUM_TYPE, 1, 1},
{"originCmd", ASSEM_1BYTE, INST_ORIGIN_COMMAND, 1, 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},
{"resolveCmd", ASSEM_1BYTE, INST_RESOLVE_COMMAND, 1, 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_STK, 2, 1},
{"strcaseLower", ASSEM_1BYTE, INST_STR_LOWER, 1, 1},
{"strcaseTitle", ASSEM_1BYTE, INST_STR_TITLE, 1, 1},
{"strcaseUpper", ASSEM_1BYTE, INST_STR_UPPER, 1, 1},
{"strcmp", ASSEM_1BYTE, INST_STR_CMP, 2, 1},
{"strcat", ASSEM_CONCAT1, INST_STR_CONCAT1, INT_MIN,1},
{"streq", ASSEM_1BYTE, INST_STR_EQ, 2, 1},
{"strfind", ASSEM_1BYTE, INST_STR_FIND, 2, 1},
{"strindex", ASSEM_1BYTE, INST_STR_INDEX, 2, 1},
{"strlen", ASSEM_1BYTE, INST_STR_LEN, 1, 1},
{"strmap", ASSEM_1BYTE, INST_STR_MAP, 3, 1},
{"strmatch", ASSEM_BOOL, INST_STR_MATCH, 2, 1},
{"strneq", ASSEM_1BYTE, INST_STR_NEQ, 2, 1},
{"strrange", ASSEM_1BYTE, INST_STR_RANGE, 3, 1},
{"strreplace", ASSEM_1BYTE, INST_STR_REPLACE, 4, 1},
{"strrfind", ASSEM_1BYTE, INST_STR_FIND_LAST, 2, 1},
{"strtrim", ASSEM_1BYTE, INST_STR_TRIM, 2, 1},
{"strtrimLeft", ASSEM_1BYTE, INST_STR_TRIM_LEFT, 2, 1},
{"strtrimRight", ASSEM_1BYTE, INST_STR_TRIM_RIGHT, 2, 1},
{"sub", ASSEM_1BYTE, INST_SUB, 2, 1},
{"tclooClass", ASSEM_1BYTE, INST_TCLOO_CLASS, 1, 1},
{"tclooIsObject", ASSEM_1BYTE, INST_TCLOO_IS_OBJECT, 1, 1},
{"tclooNamespace", ASSEM_1BYTE, INST_TCLOO_NS, 1, 1},
{"tclooSelf", ASSEM_1BYTE, INST_TCLOO_SELF, 0, 1},
{"tryCvtToBoolean", ASSEM_1BYTE, INST_TRY_CVT_TO_BOOLEAN,1, 2},
{"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},
{"verifyDict", ASSEM_1BYTE, INST_DICT_VERIFY, 1, 0},
{"yield", ASSEM_1BYTE, INST_YIELD, 1, 1},
{NULL, ASSEM_1BYTE, 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 const 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_STR_EQ, INST_STR_NEQ, INST_STR_CMP, INST_STR_LEN, /* 73-76 */
INST_LIST, /* 79 */
INST_OVER, /* 95 */
INST_PUSH_RETURN_OPTIONS, /* 108 */
INST_REVERSE, /* 126 */
INST_NOP, /* 132 */
INST_STR_MAP, /* 143 */
INST_STR_FIND, /* 144 */
INST_COROUTINE_NAME, /* 149 */
INST_NS_CURRENT, /* 151 */
INST_INFO_LEVEL_NUM, /* 152 */
INST_RESOLVE_COMMAND, /* 154 */
INST_STR_TRIM, INST_STR_TRIM_LEFT, INST_STR_TRIM_RIGHT, /* 166-168 */
INST_CONCAT_STK, /* 169 */
INST_STR_UPPER, INST_STR_LOWER, INST_STR_TITLE, /* 170-172 */
INST_NUM_TYPE /* 180 */
};
/*
* Helper macros.
*/
#if defined(TCL_DEBUG_ASSEMBLY) && defined(__GNUC__) && __GNUC__ > 2
#define DEBUG_PRINT(...) fprintf(stderr, ##__VA_ARGS__);fflush(stderr)
#elif defined(__GNUC__) && __GNUC__ > 2
#define DEBUG_PRINT(...) /* nothing */
#else
#define DEBUG_PRINT /* nothing */
#endif
/*
*-----------------------------------------------------------------------------
*
* 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 tblIdx, /* Index in TalInstructionTable of the
* operation being assembled */
int count) /* Count of operands for variadic insts */
{
int consumed = TalInstructionTable[tblIdx].operandsConsumed;
int produced = TalInstructionTable[tblIdx].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 tblIdx, /* 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[tblIdx].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);
TclUpdateAtCmdStart(op, envPtr);
BBUpdateStackReqs(bbPtr, tblIdx, count);
}
static void
BBEmitInstInt1(
AssemblyEnv* assemEnvPtr, /* Assembly environment */
int tblIdx, /* Index in TalInstructionTable of op */
int opnd, /* 1-byte operand */
int count) /* Operand count for variadic ops */
{
BBEmitOpcode(assemEnvPtr, tblIdx, count);
TclEmitInt1(opnd, assemEnvPtr->envPtr);
}
static void
BBEmitInstInt4(
AssemblyEnv* assemEnvPtr, /* Assembly environment */
int tblIdx, /* Index in TalInstructionTable of op */
int opnd, /* 4-byte operand */
int count) /* Operand count for variadic ops */
{
BBEmitOpcode(assemEnvPtr, tblIdx, 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 tblIdx, /* 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[tblIdx].tclInstCode;
if (param <= 0xFF) {
op >>= 8;
} else {
op &= 0xFF;
}
TclEmitInt1(op, envPtr);
if (param <= 0xFF) {
TclEmitInt1(param, envPtr);
} else {
TclEmitInt4(param, envPtr);
}
TclUpdateAtCmdStart(op, envPtr);
BBUpdateStackReqs(bbPtr, tblIdx, 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. */
(void)dummy;
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_AppendObjToErrorInfo(interp, objv[0]);
Tcl_AddErrorInfo(interp, "\" body, line ");
TclNewIntObj(backtrace, Tcl_GetErrorLine(interp));
Tcl_AppendObjToErrorInfo(interp, backtrace);
Tcl_AddErrorInfo(interp, ")");
return TCL_ERROR;
}
/*
* Use NRE to evaluate the bytecode from the trampoline.
*/
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 */
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.twoPtrValue.ptr1;
if (((Interp *) *codePtr->interpHandle == iPtr)
&& (codePtr->compileEpoch == iPtr->compileEpoch)
&& (codePtr->nsPtr == namespacePtr)
&& (codePtr->nsEpoch == namespacePtr->resolverEpoch)
&& (codePtr->localCachePtr
== iPtr->varFramePtr->localCachePtr)) {
return codePtr;
}
/*
* Not valid, so free it and regenerate.
*/
FreeAssembleCodeInternalRep(objPtr);
}
/*
* 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.twoPtrValue.ptr1;
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 numCommands = envPtr->numCommands;
int offset = envPtr->codeNext - envPtr->codeStart;
int depth = envPtr->currStackDepth;
(void)cmdPtr;
/*
* Make sure that the command has a single arg that is a simple word.
*/
if (parsePtr->numWords != 2) {
return TCL_ERROR;
}
tokenPtr = TokenAfter(parsePtr->tokenPtr);
if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
return TCL_ERROR;
}
/*
* Compile the code and convert any error from the compilation into
* bytecode reporting the error;
*/
if (TCL_ERROR == TclAssembleCode(envPtr, tokenPtr[1].start,
tokenPtr[1].size, TCL_EVAL_DIRECT)) {
Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
"\n (\"%.*s\" body, line %d)",
parsePtr->tokenPtr->size, parsePtr->tokenPtr->start,
Tcl_GetErrorLine(interp)));
envPtr->numCommands = numCommands;
envPtr->codeNext = envPtr->codeStart + offset;
envPtr->currStackDepth = depth;
TclCompileSyntaxError(interp, envPtr);
}
return TCL_OK;
}
/*
*-----------------------------------------------------------------------------
*
* 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 */
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);
/*
* Report errors in the parse.
*/
if (status != TCL_OK) {
if (flags & TCL_EVAL_DIRECT) {
Tcl_LogCommandInfo(interp, codePtr, parsePtr->commandStart,
parsePtr->term + 1 - parsePtr->commandStart);
}
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) {
int instLen = parsePtr->commandSize;
/* Length in bytes of the current command */
if (parsePtr->term == parsePtr->commandStart + instLen - 1) {
--instLen;
}
/*
* If tracing, show each line assembled as it happens.
*/
#ifdef TCL_COMPILE_DEBUG
if ((tclTraceCompile >= 2) && (envPtr->procPtr == NULL)) {
printf(" %4ld Assembling: ",
(long)(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 = (AssemblyEnv*)TclStackAlloc(interp, sizeof(AssemblyEnv));
/* Assembler environment under construction */
Tcl_Parse* parsePtr = (Tcl_Parse*)TclStackAlloc(interp, sizeof(Tcl_Parse));
/* Parse of one line of assembly code */
assemEnvPtr->envPtr = envPtr;
assemEnvPtr->parsePtr = parsePtr;
assemEnvPtr->cmdLine = 1;
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 */
/*
* 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(thisBB->foreignExceptions);
}
nextBB = thisBB->successor1;
if (thisBB->jtPtr != NULL) {
DeleteMirrorJumpTable(thisBB->jtPtr);
thisBB->jtPtr = NULL;
}
ckfree(thisBB);
}
/*
* Dispose what's left.
*/
Tcl_DeleteHashTable(&assemEnvPtr->labelHash);
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; /* Name of the instruction */
int tblIdx; /* 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;
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, &tblIdx) != TCL_OK) {
goto cleanup;
}
/*
* Vector on the type of instruction being processed.
*/
instType = TalInstructionTable[tblIdx].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, tblIdx, litIndex, 0);
break;
case ASSEM_1BYTE:
if (parsePtr->numWords != 1) {
Tcl_WrongNumArgs(interp, 1, &instNameObj, "");
goto cleanup;
}
BBEmitOpcode(assemEnvPtr, tblIdx, 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, tblIdx, 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, tblIdx, 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) {
goto cleanup;
}
localVar = FindLocalVar(assemEnvPtr, &tokenPtr);
if (localVar < 0) {
goto cleanup;
}
BBEmitInstInt1(assemEnvPtr, tblIdx, opnd, 0);
TclEmitInt4(localVar, envPtr);
break;
case ASSEM_CLOCK_READ:
if (parsePtr->numWords != 2) {
Tcl_WrongNumArgs(interp, 1, &instNameObj, "imm8");
goto cleanup;
}
if (GetIntegerOperand(assemEnvPtr, &tokenPtr, &opnd) != TCL_OK) {
goto cleanup;
}
if (opnd < 0 || opnd > 3) {
Tcl_SetObjResult(interp,
Tcl_NewStringObj("operand must be [0..3]", -1));
Tcl_SetErrorCode(interp, "TCL", "ASSEM", "OPERAND<0,>3", NULL);
goto cleanup;
}
BBEmitInstInt1(assemEnvPtr, tblIdx, opnd, opnd);
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, tblIdx, 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, tblIdx, 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) {
goto cleanup;
}
localVar = FindLocalVar(assemEnvPtr, &tokenPtr);
if (localVar < 0) {
goto cleanup;
}
BBEmitInstInt4(assemEnvPtr, tblIdx, 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) {
goto cleanup;
}
localVar = FindLocalVar(assemEnvPtr, &tokenPtr);
if (localVar < 0) {
goto cleanup;
}
BBEmitInstInt4(assemEnvPtr, tblIdx, 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, tblIdx, 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[tblIdx].tclInstCode
== INST_EVAL_STK) ? "script" : "expression"));
goto cleanup;
}
if (tokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
CompileEmbeddedScript(assemEnvPtr, tokenPtr+1,
TalInstructionTable+tblIdx);
} 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, tblIdx, 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, tblIdx, 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, tblIdx, 0, 0);
} else {
flags = 0;
BBEmitInstInt4(assemEnvPtr, tblIdx, 0, 0);
}
/*
* Start a new basic block at the instruction following the jump.
*/
assemEnvPtr->curr_bb->jumpLine = assemEnvPtr->cmdLine;
if (TalInstructionTable[tblIdx].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;
DEBUG_PRINT("bb %p jumpLine %d jumpOffset %d\n",
assemEnvPtr->curr_bb, assemEnvPtr->cmdLine,
envPtr->codeNext - envPtr->codeStart);
infoIndex = TclCreateAuxData(jtPtr, &tclJumptableInfoType, envPtr);
DEBUG_PRINT("auxdata index=%d\n", infoIndex);
BBEmitInstInt4(assemEnvPtr, tblIdx, 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, tblIdx, 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, tblIdx, 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, tblIdx, 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, tblIdx, opnd, opnd);
break;
case ASSEM_LVT:
if (parsePtr->numWords != 2) {
Tcl_WrongNumArgs(interp, 1, &instNameObj, "varname");
goto cleanup;
}
localVar = FindLocalVar(assemEnvPtr, &tokenPtr);
if (localVar < 0) {
goto cleanup;
}
BBEmitInst1or4(assemEnvPtr, tblIdx, localVar, 0);
break;
case ASSEM_LVT1:
if (parsePtr->numWords != 2) {
Tcl_WrongNumArgs(interp, 1, &instNameObj, "varname");
goto cleanup;
}
localVar = FindLocalVar(assemEnvPtr, &tokenPtr);
if (localVar < 0 || CheckOneByte(interp, localVar)) {
goto cleanup;
}
BBEmitInstInt1(assemEnvPtr, tblIdx, localVar, 0);
break;
case ASSEM_LVT1_SINT1:
if (parsePtr->numWords != 3) {
Tcl_WrongNumArgs(interp, 1, &instNameObj, "varName imm8");
goto cleanup;
}
localVar = FindLocalVar(assemEnvPtr, &tokenPtr);
if (localVar < 0 || CheckOneByte(interp, localVar)
|| GetIntegerOperand(assemEnvPtr, &tokenPtr, &opnd) != TCL_OK
|| CheckSignedOneByte(interp, opnd)) {
goto cleanup;
}
BBEmitInstInt1(assemEnvPtr, tblIdx, localVar, 0);
TclEmitInt1(opnd, envPtr);
break;
case ASSEM_LVT4:
if (parsePtr->numWords != 2) {
Tcl_WrongNumArgs(interp, 1, &instNameObj, "varname");
goto cleanup;
}
localVar = FindLocalVar(assemEnvPtr, &tokenPtr);
if (localVar < 0) {
goto cleanup;
}
BBEmitInstInt4(assemEnvPtr, tblIdx, 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, tblIdx, 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;
}
{
BBEmitInstInt1(assemEnvPtr, tblIdx, TCL_REG_ADVANCED | (opnd ? TCL_REG_NOCASE : 0), 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, tblIdx, 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, tblIdx, 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) {
goto cleanup;
}
localVar = FindLocalVar(assemEnvPtr, &tokenPtr);
if (localVar < 0) {
goto cleanup;
}
BBEmitInstInt4(assemEnvPtr, tblIdx, 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:
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, /* Assembly environment */
Tcl_Token* tokenPtr, /* Tcl_Token containing the script */
const TalInstDesc* instPtr) /* Instruction that determines whether
* the script is 'expr' or 'eval' */
{
CompileEnv* envPtr = assemEnvPtr->envPtr;
/* Compilation environment */
Tcl_Interp* interp = (Tcl_Interp*) envPtr->iPtr;
/* Tcl interpreter */
/*
* 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.
*
* 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 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, 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, /* Assembly environment */
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.
*/
DEBUG_PRINT("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. */
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.
*/
DEBUG_PRINT("jump table {\n");
for (i = 0; i < objc; i+=2) {
DEBUG_PRINT(" %s -> %s\n", Tcl_GetString(objv[i]),
Tcl_GetString(objv[i+1]));
hashEntry = Tcl_CreateHashEntry(jtHashPtr, Tcl_GetString(objv[i]),
&isNew);
if (!isNew) {
if (assemEnvPtr->flags & TCL_EVAL_DIRECT) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"duplicate entry in jump table for \"%s\"",
Tcl_GetString(objv[i])));
Tcl_SetErrorCode(interp, "TCL", "ASSEM", "DUPJUMPTABLEENTRY");
DeleteMirrorJumpTable(jtPtr);
return TCL_ERROR;
}
}
Tcl_SetHashValue(hashEntry, objv[i+1]);
Tcl_IncrRefCount(objv[i+1]);
}
DEBUG_PRINT("}\n");
/*
* 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(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, /* Assembly 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;
TclNewObj(operandObj);
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; /* Integer from the source code */
int status; /* Tcl status return */
/*
* Extract the next token as a string.
*/
if (GetNextOperand(assemEnvPtr, tokenPtrPtr, &intObj) != TCL_OK) {
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; /* Integer from the source code */
int status; /* Tcl status return */
/*
* Extract the next token as a string.
*/
if (GetNextOperand(assemEnvPtr, tokenPtrPtr, &intObj) != TCL_OK) {
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 *value;
int status;
/* General operand validity check */
if (GetNextOperand(assemEnvPtr, tokenPtrPtr, &value) != TCL_OK) {
return TCL_ERROR;
}
/* Convert to an integer, advance to the next token and return. */
/*
* NOTE: Indexing a list with an index before it yields the
* same result as indexing after it, and might be more easily portable
* when list size limits grow.
*/
status = TclIndexEncode(interp, value,
TCL_INDEX_BEFORE,TCL_INDEX_BEFORE, result);
Tcl_DecrRefCount(value);
*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, /* Assembly environment */
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; /* Name of the variable */
const char* varNameStr;
int varNameLen;
int localVar; /* Index of the variable in the LVT */
if (GetNextOperand(assemEnvPtr, tokenPtrPtr, &varNameObj) != TCL_OK) {
return -1;
}
varNameStr = Tcl_GetStringFromObj(varNameObj, &varNameLen);
if (CheckNamespaceQualifiers(interp, varNameStr, varNameLen)) {
Tcl_DecrRefCount(varNameObj);
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 */
{
const char* p;
for (p = name; p+2 < name+nameLen; p++) {
if ((*p == ':') && (p[1] == ':')) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"variable \"%s\" is not local", name));
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 */
/* 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 a duplicate label.
*/
if (assemEnvPtr->flags & TCL_EVAL_DIRECT) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"duplicate definition of label \"%s\"", labelName));
Tcl_SetErrorCode(interp, "TCL", "ASSEM", "DUPLABEL", labelName,
NULL);
}
return TCL_ERROR;
}
/*
* This is the first appearance of the label in the code.
*/
Tcl_SetHashValue(entry, assemEnvPtr->curr_bb);
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.
*/
currBB->jumpTarget = jumpLabel;
if (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->catchDepth = 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. Or 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, /* Assembly 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.
*/
DEBUG_PRINT("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));
DEBUG_PRINT(" %s -> %s (%d)\n",
(char*) Tcl_GetHashKey(symHash, symEntryPtr),
Tcl_GetString(symbolObj), (valEntryPtr != NULL));
if (valEntryPtr == NULL) {
ReportUndefinedLabel(assemEnvPtr, bbPtr, symbolObj);
return TCL_ERROR;
}
}
DEBUG_PRINT("}\n");
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, /* Assembly 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 */
if (assemEnvPtr->flags & TCL_EVAL_DIRECT) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"undefined label \"%s\"", Tcl_GetString(jumpTarget)));
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) {
DEBUG_PRINT("move code from %d to %d\n",
bbPtr->originalStartOffset, bbPtr->startOffset);
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) /* Assembly environment */
{
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);
DEBUG_PRINT("bbPtr = %p jumpOffset = %d auxDataIndex = %d\n",
bbPtr, bbPtr->jumpOffset, auxDataIndex);
realJumpTablePtr = (JumptableInfo*)TclFetchAuxData(envPtr, auxDataIndex);
realJumpHashPtr = &realJumpTablePtr->hashTable;
/*
* Look up every jump target in the jump hash.
*/
DEBUG_PRINT("resolve jump table {\n");
for (symEntryPtr = Tcl_FirstHashEntry(symHash, &search);
symEntryPtr != NULL;
symEntryPtr = Tcl_NextHashEntry(&search)) {
symbolObj = (Tcl_Obj*)Tcl_GetHashValue(symEntryPtr);
DEBUG_PRINT(" 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);
DEBUG_PRINT(" %s -> %s -> bb %p (pc %d) hash entry %p\n",
(char*) Tcl_GetHashKey(symHash, symEntryPtr),
Tcl_GetString(symbolObj), jumpTargetBBPtr,
jumpTargetBBPtr->startOffset, realJumpEntryPtr);
Tcl_SetHashValue(realJumpEntryPtr,
INT2PTR(jumpTargetBBPtr->startOffset - bbPtr->jumpOffset));
}
DEBUG_PRINT("}\n");
}
/*
*-----------------------------------------------------------------------------
*
* 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) /* Assembly 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, /* Assembly 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 */
/*
* 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) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"\"%s\" instruction may not appear in "
"a context where an exception has been "
"caught and not disposed of.",
tclInstructionTable[opcode].name));
Tcl_SetErrorCode(interp, "TCL", "ASSEM", "BADTHROW", NULL);
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) {
return TCL_OK;
}
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;
}
/*
* 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) /* Assembly 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 */
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) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"stack is unbalanced on exit from the code (depth=%d)",
depth));
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) /* Assembly 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, /* Assembly 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) /* Assembly environment */
{
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) /* Assembly 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;
}
/* Make sure that all catches are closed */
if (catchDepth != 0) {
Tcl_Panic("unclosed catch at end of code in "
"tclAssembly.c:BuildExceptionRanges, can't happen");
}
/* Free temp storage */
ckfree(catchIndices);
ckfree(catches);
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* block; /* 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;
if (catches[catchDepth] != NULL) {
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;
block = bbPtr->enclosingCatch;
while (catchDepth > 0) {
--catchDepth;
if (catches[catchDepth] != NULL) {
if (catches[catchDepth] != block || catchState >= BBCS_CAUGHT) {
range = envPtr->exceptArrayPtr + catchIndices[catchDepth];
range->numCodeBytes = bbPtr->startOffset - range->codeOffset;
catches[catchDepth] = NULL;
catchIndices[catchDepth] = -1;
}
catchState = block->catchState;
block = block->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* block; /* Current enclosing catch */
int catchDepth; /* Nesting depth of the current catch */
catchState = bbPtr->catchState;
block = bbPtr->enclosingCatch;
catchDepth = bbPtr->catchDepth;
while (catchDepth > 0) {
--catchDepth;
if (catches[catchDepth] != block && catchState < BBCS_CAUGHT) {
catches[catchDepth] = block;
}
catchState = block->catchState;
block = block->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* block; /* 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.
*/
block = 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;
entryPtr = Tcl_FindHashEntry(&assemEnvPtr->labelHash,
Tcl_GetString(block->jumpTarget));
if (entryPtr == NULL) {
Tcl_Panic("undefined label in tclAssembly.c:"
"BuildExceptionRanges, can't happen");
}
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) /* Assembly 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 */
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) /* Assembly environment */
{
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 ");
TclNewIntObj(lineNo, bbPtr->startLine);
Tcl_IncrRefCount(lineNo);
Tcl_AppendObjToErrorInfo(interp, lineNo);
Tcl_AddErrorInfo(interp, " and ");
if (bbPtr->successor1 != NULL) {
Tcl_SetIntObj(lineNo, bbPtr->successor1->startLine);
Tcl_AppendObjToErrorInfo(interp, 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 internalrep. 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 internalrep,
* as we do for lists and dicts.
*
* Results:
* None.
*
* Side effects:
* None.
*
*-----------------------------------------------------------------------------
*/
static void
DupAssembleCodeInternalRep(
Tcl_Obj *srcPtr,
Tcl_Obj *copyPtr)
{
(void)srcPtr;
(void)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.twoPtrValue.ptr1;
if (codePtr->refCount-- <= 1) {
TclCleanupByteCode(codePtr);
}
objPtr->typePtr = NULL;
}
/*
* Local Variables:
* mode: c
* c-basic-offset: 4
* fill-column: 78
* End:
*/