util/src/TclTk/tcl8.6.12/generic/tclAssembly.c

   1 /*
   2  * tclAssembly.c --
   3  *
   4  *      Assembler for Tcl bytecodes.
   5  *
   6  * This file contains the procedures that convert Tcl Assembly Language (TAL)
   7  * to a sequence of bytecode instructions for the Tcl execution engine.
   8  *
   9  * Copyright (c) 2010 by Ozgur Dogan Ugurlu.
  10  * Copyright (c) 2010 by Kevin B. Kenny.
  11  *
  12  * See the file "license.terms" for information on usage and redistribution of
  13  * this file, and for a DISCLAIMER OF ALL WARRANTIES.
  14  */
  15
  16 /*-
  17  *- THINGS TO DO:
  18  *- More instructions:
  19  *-   done - alternate exit point (affects stack and exception range checking)
  20  *-   break and continue - if exception ranges can be sorted out.
  21  *-   foreach_start4, foreach_step4
  22  *-   returnImm, returnStk
  23  *-   expandStart, expandStkTop, invokeExpanded, expandDrop
  24  *-   dictFirst, dictNext, dictDone
  25  *-   dictUpdateStart, dictUpdateEnd
  26  *-   jumpTable testing
  27  *-   syntax (?)
  28  *-   returnCodeBranch
  29  *-   tclooNext, tclooNextClass
  30  */
  31
  32 #include "tclInt.h"
  33 #include "tclCompile.h"
  34 #include "tclOOInt.h"
  35
  36 /*
  37  * Structure that represents a range of instructions in the bytecode.
  38  */
  39
  40 typedef struct CodeRange {
  41     int startOffset;            /* Start offset in the bytecode array */
  42     int endOffset;              /* End offset in the bytecode array */
  43 } CodeRange;
  44
  45 /*
  46  * State identified for a basic block's catch context.
  47  */
  48
  49 typedef enum BasicBlockCatchState {
  50     BBCS_UNKNOWN = 0,           /* Catch context has not yet been identified */
  51     BBCS_NONE,                  /* Block is outside of any catch */
  52     BBCS_INCATCH,               /* Block is within a catch context */
  53     BBCS_CAUGHT                 /* Block is within a catch context and
  54                                  * may be executed after an exception fires */
  55 } BasicBlockCatchState;
  56
  57 /*
  58  * Structure that defines a basic block - a linear sequence of bytecode
  59  * instructions with no jumps in or out (including not changing the
  60  * state of any exception range).
  61  */
  62
  63 typedef struct BasicBlock {
  64     int originalStartOffset;    /* Instruction offset before JUMP1s were
  65                                  * substituted with JUMP4's */
  66     int startOffset;            /* Instruction offset of the start of the
  67                                  * block */
  68     int startLine;              /* Line number in the input script of the
  69                                  * instruction at the start of the block */
  70     int jumpOffset;             /* Bytecode offset of the 'jump' instruction
  71                                  * that ends the block, or -1 if there is no
  72                                  * jump. */
  73     int jumpLine;               /* Line number in the input script of the
  74                                  * 'jump' instruction that ends the block, or
  75                                  * -1 if there is no jump */
  76     struct BasicBlock* prevPtr; /* Immediate predecessor of this block */
  77     struct BasicBlock* predecessor;
  78                                 /* Predecessor of this block in the spanning
  79                                  * tree */
  80     struct BasicBlock* successor1;
  81                                 /* BasicBlock structure of the following
  82                                  * block: NULL at the end of the bytecode
  83                                  * sequence. */
  84     Tcl_Obj* jumpTarget;        /* Jump target label if the jump target is
  85                                  * unresolved */
  86     int initialStackDepth;      /* Absolute stack depth on entry */
  87     int minStackDepth;          /* Low-water relative stack depth */
  88     int maxStackDepth;          /* High-water relative stack depth */
  89     int finalStackDepth;        /* Relative stack depth on exit */
  90     enum BasicBlockCatchState catchState;
  91                                 /* State of the block for 'catch' analysis */
  92     int catchDepth;             /* Number of nested catches in which the basic
  93                                  * block appears */
  94     struct BasicBlock* enclosingCatch;
  95                                 /* BasicBlock structure of the last startCatch
  96                                  * executed on a path to this block, or NULL
  97                                  * if there is no enclosing catch */
  98     int foreignExceptionBase;   /* Base index of foreign exceptions */
  99     int foreignExceptionCount;  /* Count of foreign exceptions */
 100     ExceptionRange* foreignExceptions;
 101                                 /* ExceptionRange structures for exception
 102                                  * ranges belonging to embedded scripts and
 103                                  * expressions in this block */
 104     JumptableInfo* jtPtr;       /* Jump table at the end of this basic block */
 105     int flags;                  /* Boolean flags */
 106 } BasicBlock;
 107
 108 /*
 109  * Flags that pertain to a basic block.
 110  */
 111
 112 enum BasicBlockFlags {
 113     BB_VISITED = (1 << 0),      /* Block has been visited in the current
 114                                  * traversal */
 115     BB_FALLTHRU = (1 << 1),     /* Control may pass from this block to a
 116                                  * successor */
 117     BB_JUMP1 = (1 << 2),        /* Basic block ends with a 1-byte-offset jump
 118                                  * and may need expansion */
 119     BB_JUMPTABLE = (1 << 3),    /* Basic block ends with a jump table */
 120     BB_BEGINCATCH = (1 << 4),   /* Block ends with a 'beginCatch' instruction,
 121                                  * marking it as the start of a 'catch'
 122                                  * sequence. The 'jumpTarget' is the exception
 123                                  * exit from the catch block. */
 124     BB_ENDCATCH = (1 << 5)      /* Block ends with an 'endCatch' instruction,
 125                                  * unwinding the catch from the exception
 126                                  * stack. */
 127 };
 128
 129 /*
 130  * Source instruction type recognized by the assembler.
 131  */
 132
 133 typedef enum TalInstType {
 134     ASSEM_1BYTE,                /* Fixed arity, 1-byte instruction */
 135     ASSEM_BEGIN_CATCH,          /* Begin catch: one 4-byte jump offset to be
 136                                  * converted to appropriate exception
 137                                  * ranges */
 138     ASSEM_BOOL,                 /* One Boolean operand */
 139     ASSEM_BOOL_LVT4,            /* One Boolean, one 4-byte LVT ref. */
 140     ASSEM_CLOCK_READ,           /* 1-byte unsigned-integer case number, in the
 141                                  * range 0-3 */
 142     ASSEM_CONCAT1,              /* 1-byte unsigned-integer operand count, must
 143                                  * be strictly positive, consumes N, produces
 144                                  * 1 */
 145     ASSEM_DICT_GET,             /* 'dict get' and related - consumes N+1
 146                                  * operands, produces 1, N > 0 */
 147     ASSEM_DICT_SET,             /* specifies key count and LVT index, consumes
 148                                  * N+1 operands, produces 1, N > 0 */
 149     ASSEM_DICT_UNSET,           /* specifies key count and LVT index, consumes
 150                                  * N operands, produces 1, N > 0 */
 151     ASSEM_END_CATCH,            /* End catch. No args. Exception range popped
 152                                  * from stack and stack pointer restored. */
 153     ASSEM_EVAL,                 /* 'eval' - evaluate a constant script (by
 154                                  * compiling it in line with the assembly
 155                                  * code! I love Tcl!) */
 156     ASSEM_INDEX,                /* 4 byte operand, integer or end-integer */
 157     ASSEM_INVOKE,               /* 1- or 4-byte operand count, must be
 158                                  * strictly positive, consumes N, produces
 159                                  * 1. */
 160     ASSEM_JUMP,                 /* Jump instructions */
 161     ASSEM_JUMP4,                /* Jump instructions forcing a 4-byte offset */
 162     ASSEM_JUMPTABLE,            /* Jumptable (switch -exact) */
 163     ASSEM_LABEL,                /* The assembly directive that defines a
 164                                  * label */
 165     ASSEM_LINDEX_MULTI,         /* 4-byte operand count, must be strictly
 166                                  * positive, consumes N, produces 1 */
 167     ASSEM_LIST,                 /* 4-byte operand count, must be nonnegative,
 168                                  * consumses N, produces 1 */
 169     ASSEM_LSET_FLAT,            /* 4-byte operand count, must be >= 3,
 170                                  * consumes N, produces 1 */
 171     ASSEM_LVT,                  /* One operand that references a local
 172                                  * variable */
 173     ASSEM_LVT1,                 /* One 1-byte operand that references a local
 174                                  * variable */
 175     ASSEM_LVT1_SINT1,           /* One 1-byte operand that references a local
 176                                  * variable, one signed-integer 1-byte
 177                                  * operand */
 178     ASSEM_LVT4,                 /* One 4-byte operand that references a local
 179                                  * variable */
 180     ASSEM_OVER,                 /* OVER: 4-byte operand count, consumes N+1,
 181                                  * produces N+2 */
 182     ASSEM_PUSH,                 /* one literal operand */
 183     ASSEM_REGEXP,               /* One Boolean operand, but weird mapping to
 184                                  * call flags */
 185     ASSEM_REVERSE,              /* REVERSE: 4-byte operand count, consumes N,
 186                                  * produces N */
 187     ASSEM_SINT1,                /* One 1-byte signed-integer operand
 188                                  * (INCR_STK_IMM) */
 189     ASSEM_SINT4_LVT4            /* Signed 4-byte integer operand followed by
 190                                  * LVT entry.  Fixed arity */
 191 } TalInstType;
 192
 193 /*
 194  * Description of an instruction recognized by the assembler.
 195  */
 196
 197 typedef struct TalInstDesc {
 198     const char *name;           /* Name of instruction. */
 199     TalInstType instType;       /* The type of instruction */
 200     int tclInstCode;            /* Instruction code. For instructions having
 201                                  * 1- and 4-byte variables, tclInstCode is
 202                                  * ((1byte)<<8) || (4byte) */
 203     int operandsConsumed;       /* Number of operands consumed by the
 204                                  * operation, or INT_MIN if the operation is
 205                                  * variadic */
 206     int operandsProduced;       /* Number of operands produced by the
 207                                  * operation. If negative, the operation has a
 208                                  * net stack effect of -1-operandsProduced */
 209 } TalInstDesc;
 210
 211 /*
 212  * Structure that holds the state of the assembler while generating code.
 213  */
 214
 215 typedef struct AssemblyEnv {
 216     CompileEnv* envPtr;         /* Compilation environment being used for code
 217                                  * generation */
 218     Tcl_Parse* parsePtr;        /* Parse of the current line of source */
 219     Tcl_HashTable labelHash;    /* Hash table whose keys are labels and whose
 220                                  * values are 'label' objects storing the code
 221                                  * offsets of the labels. */
 222     int cmdLine;                /* Current line number within the assembly
 223                                  * code */
 224     int* clNext;                /* Invisible continuation line for
 225                                  * [info frame] */
 226     BasicBlock* head_bb;        /* First basic block in the code */
 227     BasicBlock* curr_bb;        /* Current basic block */
 228     int maxDepth;               /* Maximum stack depth encountered */
 229     int curCatchDepth;          /* Current depth of catches */
 230     int maxCatchDepth;          /* Maximum depth of catches encountered */
 231     int flags;                  /* Compilation flags (TCL_EVAL_DIRECT) */
 232 } AssemblyEnv;
 233
 234 /*
 235  * Static functions defined in this file.
 236  */
 237
 238 static void             AddBasicBlockRangeToErrorInfo(AssemblyEnv*,
 239                             BasicBlock*);
 240 static BasicBlock *     AllocBB(AssemblyEnv*);
 241 static int              AssembleOneLine(AssemblyEnv* envPtr);
 242 static void             BBAdjustStackDepth(BasicBlock* bbPtr, int consumed,
 243                             int produced);
 244 static void             BBUpdateStackReqs(BasicBlock* bbPtr, int tblIdx,
 245                             int count);
 246 static void             BBEmitInstInt1(AssemblyEnv* assemEnvPtr, int tblIdx,
 247                             int opnd, int count);
 248 static void             BBEmitInstInt4(AssemblyEnv* assemEnvPtr, int tblIdx,
 249                             int opnd, int count);
 250 static void             BBEmitInst1or4(AssemblyEnv* assemEnvPtr, int tblIdx,
 251                             int param, int count);
 252 static void             BBEmitOpcode(AssemblyEnv* assemEnvPtr, int tblIdx,
 253                             int count);
 254 static int              BuildExceptionRanges(AssemblyEnv* assemEnvPtr);
 255 static int              CalculateJumpRelocations(AssemblyEnv*, int*);
 256 static int              CheckForUnclosedCatches(AssemblyEnv*);
 257 static int              CheckForThrowInWrongContext(AssemblyEnv*);
 258 static int              CheckNonThrowingBlock(AssemblyEnv*, BasicBlock*);
 259 static int              BytecodeMightThrow(unsigned char);
 260 static int              CheckJumpTableLabels(AssemblyEnv*, BasicBlock*);
 261 static int              CheckNamespaceQualifiers(Tcl_Interp*, const char*,
 262                             int);
 263 static int              CheckNonNegative(Tcl_Interp*, int);
 264 static int              CheckOneByte(Tcl_Interp*, int);
 265 static int              CheckSignedOneByte(Tcl_Interp*, int);
 266 static int              CheckStack(AssemblyEnv*);
 267 static int              CheckStrictlyPositive(Tcl_Interp*, int);
 268 static ByteCode *       CompileAssembleObj(Tcl_Interp *interp,
 269                             Tcl_Obj *objPtr);
 270 static void             CompileEmbeddedScript(AssemblyEnv*, Tcl_Token*,
 271                             const TalInstDesc*);
 272 static int              DefineLabel(AssemblyEnv* envPtr, const char* label);
 273 static void             DeleteMirrorJumpTable(JumptableInfo* jtPtr);
 274 static void             DupAssembleCodeInternalRep(Tcl_Obj* src,
 275                             Tcl_Obj* dest);
 276 static void             FillInJumpOffsets(AssemblyEnv*);
 277 static int              CreateMirrorJumpTable(AssemblyEnv* assemEnvPtr,
 278                             Tcl_Obj* jumpTable);
 279 static int              FindLocalVar(AssemblyEnv* envPtr,
 280                             Tcl_Token** tokenPtrPtr);
 281 static int              FinishAssembly(AssemblyEnv*);
 282 static void             FreeAssembleCodeInternalRep(Tcl_Obj *objPtr);
 283 static void             FreeAssemblyEnv(AssemblyEnv*);
 284 static int              GetBooleanOperand(AssemblyEnv*, Tcl_Token**, int*);
 285 static int              GetListIndexOperand(AssemblyEnv*, Tcl_Token**, int*);
 286 static int              GetIntegerOperand(AssemblyEnv*, Tcl_Token**, int*);
 287 static int              GetNextOperand(AssemblyEnv*, Tcl_Token**, Tcl_Obj**);
 288 static void             LookForFreshCatches(BasicBlock*, BasicBlock**);
 289 static void             MoveCodeForJumps(AssemblyEnv*, int);
 290 static void             MoveExceptionRangesToBasicBlock(AssemblyEnv*, int);
 291 static AssemblyEnv*     NewAssemblyEnv(CompileEnv*, int);
 292 static int              ProcessCatches(AssemblyEnv*);
 293 static int              ProcessCatchesInBasicBlock(AssemblyEnv*, BasicBlock*,
 294                             BasicBlock*, enum BasicBlockCatchState, int);
 295 static void             ResetVisitedBasicBlocks(AssemblyEnv*);
 296 static void             ResolveJumpTableTargets(AssemblyEnv*, BasicBlock*);
 297 static void             ReportUndefinedLabel(AssemblyEnv*, BasicBlock*,
 298                             Tcl_Obj*);
 299 static void             RestoreEmbeddedExceptionRanges(AssemblyEnv*);
 300 static int              StackCheckBasicBlock(AssemblyEnv*, BasicBlock *,
 301                             BasicBlock *, int);
 302 static BasicBlock*      StartBasicBlock(AssemblyEnv*, int fallthrough,
 303                             Tcl_Obj* jumpLabel);
 304 /* static int           AdvanceIp(const unsigned char *pc); */
 305 static int              StackCheckBasicBlock(AssemblyEnv*, BasicBlock *,
 306                             BasicBlock *, int);
 307 static int              StackCheckExit(AssemblyEnv*);
 308 static void             StackFreshCatches(AssemblyEnv*, BasicBlock*, int,
 309                             BasicBlock**, int*);
 310 static void             SyncStackDepth(AssemblyEnv*);
 311 static int              TclAssembleCode(CompileEnv* envPtr, const char* code,
 312                             int codeLen, int flags);
 313 static void             UnstackExpiredCatches(CompileEnv*, BasicBlock*, int,
 314                             BasicBlock**, int*);
 315
 316 /*
 317  * Tcl_ObjType that describes bytecode emitted by the assembler.
 318  */
 319
 320 static const Tcl_ObjType assembleCodeType = {
 321     "assemblecode",
 322     FreeAssembleCodeInternalRep, /* freeIntRepProc */
 323     DupAssembleCodeInternalRep,  /* dupIntRepProc */
 324     NULL,                        /* updateStringProc */
 325     NULL                         /* setFromAnyProc */
 326 };
 327
 328 /*
 329  * Source instructions recognized in the Tcl Assembly Language (TAL)
 330  */
 331
 332 static const TalInstDesc TalInstructionTable[] = {
 333     /* PUSH must be first, see the code near the end of TclAssembleCode */
 334     {"push",            ASSEM_PUSH,     (INST_PUSH1<<8
 335                                          | INST_PUSH4),         0,      1},
 336
 337     {"add",             ASSEM_1BYTE,    INST_ADD,               2,      1},
 338     {"append",          ASSEM_LVT,      (INST_APPEND_SCALAR1<<8
 339                                          | INST_APPEND_SCALAR4),1,      1},
 340     {"appendArray",     ASSEM_LVT,      (INST_APPEND_ARRAY1<<8
 341                                          | INST_APPEND_ARRAY4), 2,      1},
 342     {"appendArrayStk",  ASSEM_1BYTE,    INST_APPEND_ARRAY_STK,  3,      1},
 343     {"appendStk",       ASSEM_1BYTE,    INST_APPEND_STK,        2,      1},
 344     {"arrayExistsImm",  ASSEM_LVT4,     INST_ARRAY_EXISTS_IMM,  0,      1},
 345     {"arrayExistsStk",  ASSEM_1BYTE,    INST_ARRAY_EXISTS_STK,  1,      1},
 346     {"arrayMakeImm",    ASSEM_LVT4,     INST_ARRAY_MAKE_IMM,    0,      0},
 347     {"arrayMakeStk",    ASSEM_1BYTE,    INST_ARRAY_MAKE_STK,    1,      0},
 348     {"beginCatch",      ASSEM_BEGIN_CATCH,
 349                                         INST_BEGIN_CATCH4,      0,      0},
 350     {"bitand",          ASSEM_1BYTE,    INST_BITAND,            2,      1},
 351     {"bitnot",          ASSEM_1BYTE,    INST_BITNOT,            1,      1},
 352     {"bitor",           ASSEM_1BYTE,    INST_BITOR,             2,      1},
 353     {"bitxor",          ASSEM_1BYTE,    INST_BITXOR,            2,      1},
 354     {"clockRead",       ASSEM_CLOCK_READ, INST_CLOCK_READ,      0,      1},
 355     {"concat",          ASSEM_CONCAT1,  INST_STR_CONCAT1,       INT_MIN,1},
 356     {"concatStk",       ASSEM_LIST,     INST_CONCAT_STK,        INT_MIN,1},
 357     {"coroName",        ASSEM_1BYTE,    INST_COROUTINE_NAME,    0,      1},
 358     {"currentNamespace",ASSEM_1BYTE,    INST_NS_CURRENT,        0,      1},
 359     {"dictAppend",      ASSEM_LVT4,     INST_DICT_APPEND,       2,      1},
 360     {"dictExists",      ASSEM_DICT_GET, INST_DICT_EXISTS,       INT_MIN,1},
 361     {"dictExpand",      ASSEM_1BYTE,    INST_DICT_EXPAND,       3,      1},
 362     {"dictGet",         ASSEM_DICT_GET, INST_DICT_GET,          INT_MIN,1},
 363     {"dictIncrImm",     ASSEM_SINT4_LVT4,
 364                                         INST_DICT_INCR_IMM,     1,      1},
 365     {"dictLappend",     ASSEM_LVT4,     INST_DICT_LAPPEND,      2,      1},
 366     {"dictRecombineStk",ASSEM_1BYTE,    INST_DICT_RECOMBINE_STK,3,      0},
 367     {"dictRecombineImm",ASSEM_LVT4,     INST_DICT_RECOMBINE_IMM,2,      0},
 368     {"dictSet",         ASSEM_DICT_SET, INST_DICT_SET,          INT_MIN,1},
 369     {"dictUnset",       ASSEM_DICT_UNSET,
 370                                         INST_DICT_UNSET,        INT_MIN,1},
 371     {"div",             ASSEM_1BYTE,    INST_DIV,               2,      1},
 372     {"dup",             ASSEM_1BYTE,    INST_DUP,               1,      2},
 373     {"endCatch",        ASSEM_END_CATCH,INST_END_CATCH,         0,      0},
 374     {"eq",              ASSEM_1BYTE,    INST_EQ,                2,      1},
 375     {"eval",            ASSEM_EVAL,     INST_EVAL_STK,          1,      1},
 376     {"evalStk",         ASSEM_1BYTE,    INST_EVAL_STK,          1,      1},
 377     {"exist",           ASSEM_LVT4,     INST_EXIST_SCALAR,      0,      1},
 378     {"existArray",      ASSEM_LVT4,     INST_EXIST_ARRAY,       1,      1},
 379     {"existArrayStk",   ASSEM_1BYTE,    INST_EXIST_ARRAY_STK,   2,      1},
 380     {"existStk",        ASSEM_1BYTE,    INST_EXIST_STK,         1,      1},
 381     {"expon",           ASSEM_1BYTE,    INST_EXPON,             2,      1},
 382     {"expr",            ASSEM_EVAL,     INST_EXPR_STK,          1,      1},
 383     {"exprStk",         ASSEM_1BYTE,    INST_EXPR_STK,          1,      1},
 384     {"ge",              ASSEM_1BYTE,    INST_GE,                2,      1},
 385     {"gt",              ASSEM_1BYTE,    INST_GT,                2,      1},
 386     {"incr",            ASSEM_LVT1,     INST_INCR_SCALAR1,      1,      1},
 387     {"incrArray",       ASSEM_LVT1,     INST_INCR_ARRAY1,       2,      1},
 388     {"incrArrayImm",    ASSEM_LVT1_SINT1,
 389                                         INST_INCR_ARRAY1_IMM,   1,      1},
 390     {"incrArrayStk",    ASSEM_1BYTE,    INST_INCR_ARRAY_STK,    3,      1},
 391     {"incrArrayStkImm", ASSEM_SINT1,    INST_INCR_ARRAY_STK_IMM,2,      1},
 392     {"incrImm",         ASSEM_LVT1_SINT1,
 393                                         INST_INCR_SCALAR1_IMM,  0,      1},
 394     {"incrStk",         ASSEM_1BYTE,    INST_INCR_STK,          2,      1},
 395     {"incrStkImm",      ASSEM_SINT1,    INST_INCR_STK_IMM,      1,      1},
 396     {"infoLevelArgs",   ASSEM_1BYTE,    INST_INFO_LEVEL_ARGS,   1,      1},
 397     {"infoLevelNumber", ASSEM_1BYTE,    INST_INFO_LEVEL_NUM,    0,      1},
 398     {"invokeStk",       ASSEM_INVOKE,   (INST_INVOKE_STK1 << 8
 399                                          | INST_INVOKE_STK4),   INT_MIN,1},
 400     {"jump",            ASSEM_JUMP,     INST_JUMP1,             0,      0},
 401     {"jump4",           ASSEM_JUMP4,    INST_JUMP4,             0,      0},
 402     {"jumpFalse",       ASSEM_JUMP,     INST_JUMP_FALSE1,       1,      0},
 403     {"jumpFalse4",      ASSEM_JUMP4,    INST_JUMP_FALSE4,       1,      0},
 404     {"jumpTable",       ASSEM_JUMPTABLE,INST_JUMP_TABLE,        1,      0},
 405     {"jumpTrue",        ASSEM_JUMP,     INST_JUMP_TRUE1,        1,      0},
 406     {"jumpTrue4",       ASSEM_JUMP4,    INST_JUMP_TRUE4,        1,      0},
 407     {"label",           ASSEM_LABEL,    0,                      0,      0},
 408     {"land",            ASSEM_1BYTE,    INST_LAND,              2,      1},
 409     {"lappend",         ASSEM_LVT,      (INST_LAPPEND_SCALAR1<<8
 410                                          | INST_LAPPEND_SCALAR4),
 411                                                                 1,      1},
 412     {"lappendArray",    ASSEM_LVT,      (INST_LAPPEND_ARRAY1<<8
 413                                          | INST_LAPPEND_ARRAY4),2,      1},
 414     {"lappendArrayStk", ASSEM_1BYTE,    INST_LAPPEND_ARRAY_STK, 3,      1},
 415     {"lappendList",     ASSEM_LVT4,     INST_LAPPEND_LIST,      1,      1},
 416     {"lappendListArray",ASSEM_LVT4,     INST_LAPPEND_LIST_ARRAY,2,      1},
 417     {"lappendListArrayStk", ASSEM_1BYTE,INST_LAPPEND_LIST_ARRAY_STK, 3, 1},
 418     {"lappendListStk",  ASSEM_1BYTE,    INST_LAPPEND_LIST_STK,  2,      1},
 419     {"lappendStk",      ASSEM_1BYTE,    INST_LAPPEND_STK,       2,      1},
 420     {"le",              ASSEM_1BYTE,    INST_LE,                2,      1},
 421     {"lindexMulti",     ASSEM_LINDEX_MULTI,
 422                                         INST_LIST_INDEX_MULTI,  INT_MIN,1},
 423     {"list",            ASSEM_LIST,     INST_LIST,              INT_MIN,1},
 424     {"listConcat",      ASSEM_1BYTE,    INST_LIST_CONCAT,       2,      1},
 425     {"listIn",          ASSEM_1BYTE,    INST_LIST_IN,           2,      1},
 426     {"listIndex",       ASSEM_1BYTE,    INST_LIST_INDEX,        2,      1},
 427     {"listIndexImm",    ASSEM_INDEX,    INST_LIST_INDEX_IMM,    1,      1},
 428     {"listLength",      ASSEM_1BYTE,    INST_LIST_LENGTH,       1,      1},
 429     {"listNotIn",       ASSEM_1BYTE,    INST_LIST_NOT_IN,       2,      1},
 430     {"load",            ASSEM_LVT,      (INST_LOAD_SCALAR1 << 8
 431                                          | INST_LOAD_SCALAR4),  0,      1},
 432     {"loadArray",       ASSEM_LVT,      (INST_LOAD_ARRAY1<<8
 433                                          | INST_LOAD_ARRAY4),   1,      1},
 434     {"loadArrayStk",    ASSEM_1BYTE,    INST_LOAD_ARRAY_STK,    2,      1},
 435     {"loadStk",         ASSEM_1BYTE,    INST_LOAD_STK,          1,      1},
 436     {"lor",             ASSEM_1BYTE,    INST_LOR,               2,      1},
 437     {"lsetFlat",        ASSEM_LSET_FLAT,INST_LSET_FLAT,         INT_MIN,1},
 438     {"lsetList",        ASSEM_1BYTE,    INST_LSET_LIST,         3,      1},
 439     {"lshift",          ASSEM_1BYTE,    INST_LSHIFT,            2,      1},
 440     {"lt",              ASSEM_1BYTE,    INST_LT,                2,      1},
 441     {"mod",             ASSEM_1BYTE,    INST_MOD,               2,      1},
 442     {"mult",            ASSEM_1BYTE,    INST_MULT,              2,      1},
 443     {"neq",             ASSEM_1BYTE,    INST_NEQ,               2,      1},
 444     {"nop",             ASSEM_1BYTE,    INST_NOP,               0,      0},
 445     {"not",             ASSEM_1BYTE,    INST_LNOT,              1,      1},
 446     {"nsupvar",         ASSEM_LVT4,     INST_NSUPVAR,           2,      1},
 447     {"numericType",     ASSEM_1BYTE,    INST_NUM_TYPE,          1,      1},
 448     {"originCmd",       ASSEM_1BYTE,    INST_ORIGIN_COMMAND,    1,      1},
 449     {"over",            ASSEM_OVER,     INST_OVER,              INT_MIN,-1-1},
 450     {"pop",             ASSEM_1BYTE,    INST_POP,               1,      0},
 451     {"pushReturnCode",  ASSEM_1BYTE,    INST_PUSH_RETURN_CODE,  0,      1},
 452     {"pushReturnOpts",  ASSEM_1BYTE,    INST_PUSH_RETURN_OPTIONS,
 453                                                                 0,      1},
 454     {"pushResult",      ASSEM_1BYTE,    INST_PUSH_RESULT,       0,      1},
 455     {"regexp",          ASSEM_REGEXP,   INST_REGEXP,            2,      1},
 456     {"resolveCmd",      ASSEM_1BYTE,    INST_RESOLVE_COMMAND,   1,      1},
 457     {"reverse",         ASSEM_REVERSE,  INST_REVERSE,           INT_MIN,-1-0},
 458     {"rshift",          ASSEM_1BYTE,    INST_RSHIFT,            2,      1},
 459     {"store",           ASSEM_LVT,      (INST_STORE_SCALAR1<<8
 460                                          | INST_STORE_SCALAR4), 1,      1},
 461     {"storeArray",      ASSEM_LVT,      (INST_STORE_ARRAY1<<8
 462                                          | INST_STORE_ARRAY4),  2,      1},
 463     {"storeArrayStk",   ASSEM_1BYTE,    INST_STORE_ARRAY_STK,   3,      1},
 464     {"storeStk",        ASSEM_1BYTE,    INST_STORE_STK,         2,      1},
 465     {"strcaseLower",    ASSEM_1BYTE,    INST_STR_LOWER,         1,      1},
 466     {"strcaseTitle",    ASSEM_1BYTE,    INST_STR_TITLE,         1,      1},
 467     {"strcaseUpper",    ASSEM_1BYTE,    INST_STR_UPPER,         1,      1},
 468     {"strcmp",          ASSEM_1BYTE,    INST_STR_CMP,           2,      1},
 469     {"strcat",          ASSEM_CONCAT1,  INST_STR_CONCAT1,       INT_MIN,1},
 470     {"streq",           ASSEM_1BYTE,    INST_STR_EQ,            2,      1},
 471     {"strfind",         ASSEM_1BYTE,    INST_STR_FIND,          2,      1},
 472     {"strindex",        ASSEM_1BYTE,    INST_STR_INDEX,         2,      1},
 473     {"strlen",          ASSEM_1BYTE,    INST_STR_LEN,           1,      1},
 474     {"strmap",          ASSEM_1BYTE,    INST_STR_MAP,           3,      1},
 475     {"strmatch",        ASSEM_BOOL,     INST_STR_MATCH,         2,      1},
 476     {"strneq",          ASSEM_1BYTE,    INST_STR_NEQ,           2,      1},
 477     {"strrange",        ASSEM_1BYTE,    INST_STR_RANGE,         3,      1},
 478     {"strreplace",      ASSEM_1BYTE,    INST_STR_REPLACE,       4,      1},
 479     {"strrfind",        ASSEM_1BYTE,    INST_STR_FIND_LAST,     2,      1},
 480     {"strtrim",         ASSEM_1BYTE,    INST_STR_TRIM,          2,      1},
 481     {"strtrimLeft",     ASSEM_1BYTE,    INST_STR_TRIM_LEFT,     2,      1},
 482     {"strtrimRight",    ASSEM_1BYTE,    INST_STR_TRIM_RIGHT,    2,      1},
 483     {"sub",             ASSEM_1BYTE,    INST_SUB,               2,      1},
 484     {"tclooClass",      ASSEM_1BYTE,    INST_TCLOO_CLASS,       1,      1},
 485     {"tclooIsObject",   ASSEM_1BYTE,    INST_TCLOO_IS_OBJECT,   1,      1},
 486     {"tclooNamespace",  ASSEM_1BYTE,    INST_TCLOO_NS,          1,      1},
 487     {"tclooSelf",       ASSEM_1BYTE,    INST_TCLOO_SELF,        0,      1},
 488     {"tryCvtToBoolean", ASSEM_1BYTE,    INST_TRY_CVT_TO_BOOLEAN,1,      2},
 489     {"tryCvtToNumeric", ASSEM_1BYTE,    INST_TRY_CVT_TO_NUMERIC,1,      1},
 490     {"uminus",          ASSEM_1BYTE,    INST_UMINUS,            1,      1},
 491     {"unset",           ASSEM_BOOL_LVT4,INST_UNSET_SCALAR,      0,      0},
 492     {"unsetArray",      ASSEM_BOOL_LVT4,INST_UNSET_ARRAY,       1,      0},
 493     {"unsetArrayStk",   ASSEM_BOOL,     INST_UNSET_ARRAY_STK,   2,      0},
 494     {"unsetStk",        ASSEM_BOOL,     INST_UNSET_STK,         1,      0},
 495     {"uplus",           ASSEM_1BYTE,    INST_UPLUS,             1,      1},
 496     {"upvar",           ASSEM_LVT4,     INST_UPVAR,             2,      1},
 497     {"variable",        ASSEM_LVT4,     INST_VARIABLE,          1,      0},
 498     {"verifyDict",      ASSEM_1BYTE,    INST_DICT_VERIFY,       1,      0},
 499     {"yield",           ASSEM_1BYTE,    INST_YIELD,             1,      1},
 500     {NULL,              ASSEM_1BYTE,            0,                      0,      0}
 501 };
 502
 503 /*
 504  * List of instructions that cannot throw an exception under any
 505  * circumstances.  These instructions are the ones that are permissible after
 506  * an exception is caught but before the corresponding exception range is
 507  * popped from the stack.
 508  * The instructions must be in ascending order by numeric operation code.
 509  */
 510
 511 static const unsigned char NonThrowingByteCodes[] = {
 512     INST_PUSH1, INST_PUSH4, INST_POP, INST_DUP,                 /* 1-4 */
 513     INST_JUMP1, INST_JUMP4,                                     /* 34-35 */
 514     INST_END_CATCH, INST_PUSH_RESULT, INST_PUSH_RETURN_CODE,    /* 70-72 */
 515     INST_STR_EQ, INST_STR_NEQ, INST_STR_CMP, INST_STR_LEN,      /* 73-76 */
 516     INST_LIST,                                                  /* 79 */
 517     INST_OVER,                                                  /* 95 */
 518     INST_PUSH_RETURN_OPTIONS,                                   /* 108 */
 519     INST_REVERSE,                                               /* 126 */
 520     INST_NOP,                                                   /* 132 */
 521     INST_STR_MAP,                                               /* 143 */
 522     INST_STR_FIND,                                              /* 144 */
 523     INST_COROUTINE_NAME,                                        /* 149 */
 524     INST_NS_CURRENT,                                            /* 151 */
 525     INST_INFO_LEVEL_NUM,                                        /* 152 */
 526     INST_RESOLVE_COMMAND,                                       /* 154 */
 527     INST_STR_TRIM, INST_STR_TRIM_LEFT, INST_STR_TRIM_RIGHT,     /* 166-168 */
 528     INST_CONCAT_STK,                                            /* 169 */
 529     INST_STR_UPPER, INST_STR_LOWER, INST_STR_TITLE,             /* 170-172 */
 530     INST_NUM_TYPE                                               /* 180 */
 531 };
 532
 533 /*
 534  * Helper macros.
 535  */
 536
 537 #if defined(TCL_DEBUG_ASSEMBLY) && defined(__GNUC__) && __GNUC__ > 2
 538 #define DEBUG_PRINT(...)        fprintf(stderr, ##__VA_ARGS__);fflush(stderr)
 539 #elif defined(__GNUC__) && __GNUC__ > 2
 540 #define DEBUG_PRINT(...)        /* nothing */
 541 #else
 542 #define DEBUG_PRINT             /* nothing */
 543 #endif
 544 \f
 545 /*
 546  *-----------------------------------------------------------------------------
 547  *
 548  * BBAdjustStackDepth --
 549  *
 550  *      When an opcode is emitted, adjusts the stack information in the basic
 551  *      block to reflect the number of operands produced and consumed.
 552  *
 553  * Results:
 554  *      None.
 555  *
 556  * Side effects:
 557  *      Updates minimum, maximum and final stack requirements in the basic
 558  *      block.
 559  *
 560  *-----------------------------------------------------------------------------
 561  */
 562
 563 static void
 564 BBAdjustStackDepth(
 565     BasicBlock *bbPtr,          /* Structure describing the basic block */
 566     int consumed,               /* Count of operands consumed by the
 567                                  * operation */
 568     int produced)               /* Count of operands produced by the
 569                                  * operation */
 570 {
 571     int depth = bbPtr->finalStackDepth;
 572
 573     depth -= consumed;
 574     if (depth < bbPtr->minStackDepth) {
 575         bbPtr->minStackDepth = depth;
 576     }
 577     depth += produced;
 578     if (depth > bbPtr->maxStackDepth) {
 579         bbPtr->maxStackDepth = depth;
 580     }
 581     bbPtr->finalStackDepth = depth;
 582 }
 583 \f
 584 /*
 585  *-----------------------------------------------------------------------------
 586  *
 587  * BBUpdateStackReqs --
 588  *
 589  *      Updates the stack requirements of a basic block, given the opcode
 590  *      being emitted and an operand count.
 591  *
 592  * Results:
 593  *      None.
 594  *
 595  * Side effects:
 596  *      Updates min, max and final stack requirements in the basic block.
 597  *
 598  * Notes:
 599  *      This function must not be called for instructions such as REVERSE and
 600  *      OVER that are variadic but do not consume all their operands. Instead,
 601  *      BBAdjustStackDepth should be called directly.
 602  *
 603  *      count should be provided only for variadic operations. For operations
 604  *      with known arity, count should be 0.
 605  *
 606  *-----------------------------------------------------------------------------
 607  */
 608
 609 static void
 610 BBUpdateStackReqs(
 611     BasicBlock* bbPtr,          /* Structure describing the basic block */
 612     int tblIdx,                 /* Index in TalInstructionTable of the
 613                                  * operation being assembled */
 614     int count)                  /* Count of operands for variadic insts */
 615 {
 616     int consumed = TalInstructionTable[tblIdx].operandsConsumed;
 617     int produced = TalInstructionTable[tblIdx].operandsProduced;
 618
 619     if (consumed == INT_MIN) {
 620         /*
 621          * The instruction is variadic; it consumes 'count' operands.
 622          */
 623
 624         consumed = count;
 625     }
 626     if (produced < 0) {
 627         /*
 628          * The instruction leaves some of its variadic operands on the stack,
 629          * with net stack effect of '-1-produced'
 630          */
 631
 632         produced = consumed - produced - 1;
 633     }
 634     BBAdjustStackDepth(bbPtr, consumed, produced);
 635 }
 636 \f
 637 /*
 638  *-----------------------------------------------------------------------------
 639  *
 640  * BBEmitOpcode, BBEmitInstInt1, BBEmitInstInt4 --
 641  *
 642  *      Emit the opcode part of an instruction, or the entirety of an
 643  *      instruction with a 1- or 4-byte operand, and adjust stack
 644  *      requirements.
 645  *
 646  * Results:
 647  *      None.
 648  *
 649  * Side effects:
 650  *      Stores instruction and operand in the operand stream, and adjusts the
 651  *      stack.
 652  *
 653  *-----------------------------------------------------------------------------
 654  */
 655
 656 static void
 657 BBEmitOpcode(
 658     AssemblyEnv* assemEnvPtr,   /* Assembly environment */
 659     int tblIdx,                 /* Table index in TalInstructionTable of op */
 660     int count)                  /* Operand count for variadic ops */
 661 {
 662     CompileEnv* envPtr = assemEnvPtr->envPtr;
 663                                 /* Compilation environment */
 664     BasicBlock* bbPtr = assemEnvPtr->curr_bb;
 665                                 /* Current basic block */
 666     int op = TalInstructionTable[tblIdx].tclInstCode & 0xFF;
 667
 668     /*
 669      * If this is the first instruction in a basic block, record its line
 670      * number.
 671      */
 672
 673     if (bbPtr->startOffset == envPtr->codeNext - envPtr->codeStart) {
 674         bbPtr->startLine = assemEnvPtr->cmdLine;
 675     }
 676
 677     TclEmitInt1(op, envPtr);
 678     TclUpdateAtCmdStart(op, envPtr);
 679     BBUpdateStackReqs(bbPtr, tblIdx, count);
 680 }
 681
 682 static void
 683 BBEmitInstInt1(
 684     AssemblyEnv* assemEnvPtr,   /* Assembly environment */
 685     int tblIdx,                 /* Index in TalInstructionTable of op */
 686     int opnd,                   /* 1-byte operand */
 687     int count)                  /* Operand count for variadic ops */
 688 {
 689     BBEmitOpcode(assemEnvPtr, tblIdx, count);
 690     TclEmitInt1(opnd, assemEnvPtr->envPtr);
 691 }
 692
 693 static void
 694 BBEmitInstInt4(
 695     AssemblyEnv* assemEnvPtr,   /* Assembly environment */
 696     int tblIdx,                 /* Index in TalInstructionTable of op */
 697     int opnd,                   /* 4-byte operand */
 698     int count)                  /* Operand count for variadic ops */
 699 {
 700     BBEmitOpcode(assemEnvPtr, tblIdx, count);
 701     TclEmitInt4(opnd, assemEnvPtr->envPtr);
 702 }
 703 \f
 704 /*
 705  *-----------------------------------------------------------------------------
 706  *
 707  * BBEmitInst1or4 --
 708  *
 709  *      Emits a 1- or 4-byte operation according to the magnitude of the
 710  *      operand.
 711  *
 712  *-----------------------------------------------------------------------------
 713  */
 714
 715 static void
 716 BBEmitInst1or4(
 717     AssemblyEnv* assemEnvPtr,   /* Assembly environment */
 718     int tblIdx,                 /* Index in TalInstructionTable of op */
 719     int param,                  /* Variable-length parameter */
 720     int count)                  /* Arity if variadic */
 721 {
 722     CompileEnv* envPtr = assemEnvPtr->envPtr;
 723                                 /* Compilation environment */
 724     BasicBlock* bbPtr = assemEnvPtr->curr_bb;
 725                                 /* Current basic block */
 726     int op = TalInstructionTable[tblIdx].tclInstCode;
 727
 728     if (param <= 0xFF) {
 729         op >>= 8;
 730     } else {
 731         op &= 0xFF;
 732     }
 733     TclEmitInt1(op, envPtr);
 734     if (param <= 0xFF) {
 735         TclEmitInt1(param, envPtr);
 736     } else {
 737         TclEmitInt4(param, envPtr);
 738     }
 739     TclUpdateAtCmdStart(op, envPtr);
 740     BBUpdateStackReqs(bbPtr, tblIdx, count);
 741 }
 742 \f
 743 /*
 744  *-----------------------------------------------------------------------------
 745  *
 746  * Tcl_AssembleObjCmd, TclNRAssembleObjCmd --
 747  *
 748  *      Direct evaluation path for tcl::unsupported::assemble
 749  *
 750  * Results:
 751  *      Returns a standard Tcl result.
 752  *
 753  * Side effects:
 754  *      Assembles the code in objv[1], and executes it, so side effects
 755  *      include whatever the code does.
 756  *
 757  *-----------------------------------------------------------------------------
 758  */
 759
 760 int
 761 Tcl_AssembleObjCmd(
 762     ClientData dummy,           /* Not used. */
 763     Tcl_Interp *interp,         /* Current interpreter. */
 764     int objc,                   /* Number of arguments. */
 765     Tcl_Obj *const objv[])      /* Argument objects. */
 766 {
 767     /*
 768      * Boilerplate - make sure that there is an NRE trampoline on the C stack
 769      * because there needs to be one in place to execute bytecode.
 770      */
 771
 772     return Tcl_NRCallObjProc(interp, TclNRAssembleObjCmd, dummy, objc, objv);
 773 }
 774
 775 int
 776 TclNRAssembleObjCmd(
 777     ClientData dummy,           /* Not used. */
 778     Tcl_Interp *interp,         /* Current interpreter. */
 779     int objc,                   /* Number of arguments. */
 780     Tcl_Obj *const objv[])      /* Argument objects. */
 781 {
 782     ByteCode *codePtr;          /* Pointer to the bytecode to execute */
 783     Tcl_Obj* backtrace;         /* Object where extra error information is
 784                                  * constructed. */
 785
 786     (void)dummy;
 787     if (objc != 2) {
 788         Tcl_WrongNumArgs(interp, 1, objv, "bytecodeList");
 789         return TCL_ERROR;
 790     }
 791
 792     /*
 793      * Assemble the source to bytecode.
 794      */
 795
 796     codePtr = CompileAssembleObj(interp, objv[1]);
 797
 798     /*
 799      * On failure, report error line.
 800      */
 801
 802     if (codePtr == NULL) {
 803         Tcl_AddErrorInfo(interp, "\n    (\"");
 804         Tcl_AppendObjToErrorInfo(interp, objv[0]);
 805         Tcl_AddErrorInfo(interp, "\" body, line ");
 806         TclNewIntObj(backtrace, Tcl_GetErrorLine(interp));
 807         Tcl_AppendObjToErrorInfo(interp, backtrace);
 808         Tcl_AddErrorInfo(interp, ")");
 809         return TCL_ERROR;
 810     }
 811
 812     /*
 813      * Use NRE to evaluate the bytecode from the trampoline.
 814      */
 815
 816     return TclNRExecuteByteCode(interp, codePtr);
 817 }
 818 \f
 819 /*
 820  *-----------------------------------------------------------------------------
 821  *
 822  * CompileAssembleObj --
 823  *
 824  *      Sets up and assembles Tcl bytecode for the direct-execution path in
 825  *      the Tcl bytecode assembler.
 826  *
 827  * Results:
 828  *      Returns a pointer to the assembled code. Returns NULL if the assembly
 829  *      fails for any reason, with an appropriate error message in the
 830  *      interpreter.
 831  *
 832  *-----------------------------------------------------------------------------
 833  */
 834
 835 static ByteCode *
 836 CompileAssembleObj(
 837     Tcl_Interp *interp,         /* Tcl interpreter */
 838     Tcl_Obj *objPtr)            /* Source code to assemble */
 839 {
 840     Interp *iPtr = (Interp *) interp;
 841                                 /* Internals of the interpreter */
 842     CompileEnv compEnv;         /* Compilation environment structure */
 843     ByteCode *codePtr = NULL;
 844                                 /* Bytecode resulting from the assembly */
 845     Namespace* namespacePtr;    /* Namespace in which variable and command
 846                                  * names in the bytecode resolve */
 847     int status;                 /* Status return from Tcl_AssembleCode */
 848     const char* source;         /* String representation of the source code */
 849     int sourceLen;              /* Length of the source code in bytes */
 850
 851     /*
 852      * Get the expression ByteCode from the object. If it exists, make sure it
 853      * is valid in the current context.
 854      */
 855
 856     if (objPtr->typePtr == &assembleCodeType) {
 857         namespacePtr = iPtr->varFramePtr->nsPtr;
 858         codePtr = (ByteCode *)objPtr->internalRep.twoPtrValue.ptr1;
 859         if (((Interp *) *codePtr->interpHandle == iPtr)
 860                 && (codePtr->compileEpoch == iPtr->compileEpoch)
 861                 && (codePtr->nsPtr == namespacePtr)
 862                 && (codePtr->nsEpoch == namespacePtr->resolverEpoch)
 863                 && (codePtr->localCachePtr
 864                         == iPtr->varFramePtr->localCachePtr)) {
 865             return codePtr;
 866         }
 867
 868         /*
 869          * Not valid, so free it and regenerate.
 870          */
 871
 872         FreeAssembleCodeInternalRep(objPtr);
 873     }
 874
 875     /*
 876      * Set up the compilation environment, and assemble the code.
 877      */
 878
 879     source = TclGetStringFromObj(objPtr, &sourceLen);
 880     TclInitCompileEnv(interp, &compEnv, source, sourceLen, NULL, 0);
 881     status = TclAssembleCode(&compEnv, source, sourceLen, TCL_EVAL_DIRECT);
 882     if (status != TCL_OK) {
 883         /*
 884          * Assembly failed. Clean up and report the error.
 885          */
 886         TclFreeCompileEnv(&compEnv);
 887         return NULL;
 888     }
 889
 890     /*
 891      * Add a "done" instruction as the last instruction and change the object
 892      * into a ByteCode object. Ownership of the literal objects and aux data
 893      * items is given to the ByteCode object.
 894      */
 895
 896     TclEmitOpcode(INST_DONE, &compEnv);
 897     TclInitByteCodeObj(objPtr, &compEnv);
 898     objPtr->typePtr = &assembleCodeType;
 899     TclFreeCompileEnv(&compEnv);
 900
 901     /*
 902      * Record the local variable context to which the bytecode pertains
 903      */
 904
 905     codePtr = (ByteCode *)objPtr->internalRep.twoPtrValue.ptr1;
 906     if (iPtr->varFramePtr->localCachePtr) {
 907         codePtr->localCachePtr = iPtr->varFramePtr->localCachePtr;
 908         codePtr->localCachePtr->refCount++;
 909     }
 910
 911     /*
 912      * Report on what the assembler did.
 913      */
 914
 915 #ifdef TCL_COMPILE_DEBUG
 916     if (tclTraceCompile >= 2) {
 917         TclPrintByteCodeObj(interp, objPtr);
 918         fflush(stdout);
 919     }
 920 #endif /* TCL_COMPILE_DEBUG */
 921
 922     return codePtr;
 923 }
 924 \f
 925 /*
 926  *-----------------------------------------------------------------------------
 927  *
 928  * TclCompileAssembleCmd --
 929  *
 930  *      Compilation procedure for the '::tcl::unsupported::assemble' command.
 931  *
 932  * Results:
 933  *      Returns a standard Tcl result.
 934  *
 935  * Side effects:
 936  *      Puts the result of assembling the code into the bytecode stream in
 937  *      'compileEnv'.
 938  *
 939  * This procedure makes sure that the command has a single arg, which is
 940  * constant. If that condition is met, the procedure calls TclAssembleCode to
 941  * produce bytecode for the given assembly code, and returns any error
 942  * resulting from the assembly.
 943  *
 944  *-----------------------------------------------------------------------------
 945  */
 946
 947 int
 948 TclCompileAssembleCmd(
 949     Tcl_Interp *interp,         /* Used for error reporting. */
 950     Tcl_Parse *parsePtr,        /* Points to a parse structure for the command
 951                                  * created by Tcl_ParseCommand. */
 952     Command *cmdPtr,            /* Points to defintion of command being
 953                                  * compiled. */
 954     CompileEnv *envPtr)         /* Holds resulting instructions. */
 955 {
 956     Tcl_Token *tokenPtr;        /* Token in the input script */
 957
 958     int numCommands = envPtr->numCommands;
 959     int offset = envPtr->codeNext - envPtr->codeStart;
 960     int depth = envPtr->currStackDepth;
 961     (void)cmdPtr;
 962     /*
 963      * Make sure that the command has a single arg that is a simple word.
 964      */
 965
 966     if (parsePtr->numWords != 2) {
 967         return TCL_ERROR;
 968     }
 969     tokenPtr = TokenAfter(parsePtr->tokenPtr);
 970     if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
 971         return TCL_ERROR;
 972     }
 973
 974     /*
 975      * Compile the code and convert any error from the compilation into
 976      * bytecode reporting the error;
 977      */
 978
 979     if (TCL_ERROR == TclAssembleCode(envPtr, tokenPtr[1].start,
 980             tokenPtr[1].size, TCL_EVAL_DIRECT)) {
 981
 982         Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
 983                 "\n    (\"%.*s\" body, line %d)",
 984                 parsePtr->tokenPtr->size, parsePtr->tokenPtr->start,
 985                 Tcl_GetErrorLine(interp)));
 986         envPtr->numCommands = numCommands;
 987         envPtr->codeNext = envPtr->codeStart + offset;
 988         envPtr->currStackDepth = depth;
 989         TclCompileSyntaxError(interp, envPtr);
 990     }
 991     return TCL_OK;
 992 }
 993 \f
 994 /*
 995  *-----------------------------------------------------------------------------
 996  *
 997  * TclAssembleCode --
 998  *
 999  *      Take a list of instructions in a Tcl_Obj, and assemble them to Tcl
1000  *      bytecodes
1001  *
1002  * Results:
1003  *      Returns TCL_OK on success, TCL_ERROR on failure.  If 'flags' includes
1004  *      TCL_EVAL_DIRECT, places an error message in the interpreter result.
1005  *
1006  * Side effects:
1007  *      Adds byte codes to the compile environment, and updates the
1008  *      environment's stack depth.
1009  *
1010  *-----------------------------------------------------------------------------
1011  */
1012
1013 static int
1014 TclAssembleCode(
1015     CompileEnv *envPtr,         /* Compilation environment that is to receive
1016                                  * the generated bytecode */
1017     const char* codePtr,        /* Assembly-language code to be processed */
1018     int codeLen,                /* Length of the code */
1019     int flags)                  /* OR'ed combination of flags */
1020 {
1021     Tcl_Interp* interp = (Tcl_Interp*) envPtr->iPtr;
1022                                 /* Tcl interpreter */
1023     /*
1024      * Walk through the assembly script using the Tcl parser.  Each 'command'
1025      * will be an instruction or assembly directive.
1026      */
1027
1028     const char* instPtr = codePtr;
1029                                 /* Where to start looking for a line of code */
1030     const char* nextPtr;        /* Pointer to the end of the line of code */
1031     int bytesLeft = codeLen;    /* Number of bytes of source code remaining to
1032                                  * be parsed */
1033     int status;                 /* Tcl status return */
1034     AssemblyEnv* assemEnvPtr = NewAssemblyEnv(envPtr, flags);
1035     Tcl_Parse* parsePtr = assemEnvPtr->parsePtr;
1036
1037     do {
1038         /*
1039          * Parse out one command line from the assembly script.
1040          */
1041
1042         status = Tcl_ParseCommand(interp, instPtr, bytesLeft, 0, parsePtr);
1043
1044         /*
1045          * Report errors in the parse.
1046          */
1047
1048         if (status != TCL_OK) {
1049             if (flags & TCL_EVAL_DIRECT) {
1050                 Tcl_LogCommandInfo(interp, codePtr, parsePtr->commandStart,
1051                         parsePtr->term + 1 - parsePtr->commandStart);
1052             }
1053             FreeAssemblyEnv(assemEnvPtr);
1054             return TCL_ERROR;
1055         }
1056
1057         /*
1058          * Advance the pointers around any leading commentary.
1059          */
1060
1061         TclAdvanceLines(&assemEnvPtr->cmdLine, instPtr,
1062                 parsePtr->commandStart);
1063         TclAdvanceContinuations(&assemEnvPtr->cmdLine, &assemEnvPtr->clNext,
1064                 parsePtr->commandStart - envPtr->source);
1065
1066         /*
1067          * Process the line of code.
1068          */
1069
1070         if (parsePtr->numWords > 0) {
1071             int instLen = parsePtr->commandSize;
1072                     /* Length in bytes of the current command */
1073
1074             if (parsePtr->term == parsePtr->commandStart + instLen - 1) {
1075                 --instLen;
1076             }
1077
1078             /*
1079              * If tracing, show each line assembled as it happens.
1080              */
1081
1082 #ifdef TCL_COMPILE_DEBUG
1083             if ((tclTraceCompile >= 2) && (envPtr->procPtr == NULL)) {
1084                 printf("  %4ld Assembling: ",
1085                         (long)(envPtr->codeNext - envPtr->codeStart));
1086                 TclPrintSource(stdout, parsePtr->commandStart,
1087                         TclMin(instLen, 55));
1088                 printf("\n");
1089             }
1090 #endif
1091             if (AssembleOneLine(assemEnvPtr) != TCL_OK) {
1092                 if (flags & TCL_EVAL_DIRECT) {
1093                     Tcl_LogCommandInfo(interp, codePtr,
1094                             parsePtr->commandStart, instLen);
1095                 }
1096                 Tcl_FreeParse(parsePtr);
1097                 FreeAssemblyEnv(assemEnvPtr);
1098                 return TCL_ERROR;
1099             }
1100         }
1101
1102         /*
1103          * Advance to the next line of code.
1104          */
1105
1106         nextPtr = parsePtr->commandStart + parsePtr->commandSize;
1107         bytesLeft -= (nextPtr - instPtr);
1108         instPtr = nextPtr;
1109         TclAdvanceLines(&assemEnvPtr->cmdLine, parsePtr->commandStart,
1110                 instPtr);
1111         TclAdvanceContinuations(&assemEnvPtr->cmdLine, &assemEnvPtr->clNext,
1112                 instPtr - envPtr->source);
1113         Tcl_FreeParse(parsePtr);
1114     } while (bytesLeft > 0);
1115
1116     /*
1117      * Done with parsing the code.
1118      */
1119
1120     status = FinishAssembly(assemEnvPtr);
1121     FreeAssemblyEnv(assemEnvPtr);
1122     return status;
1123 }
1124 \f
1125 /*
1126  *-----------------------------------------------------------------------------
1127  *
1128  * NewAssemblyEnv --
1129  *
1130  *      Creates an environment for the assembler to run in.
1131  *
1132  * Results:
1133  *      Allocates, initialises and returns an assembler environment
1134  *
1135  *-----------------------------------------------------------------------------
1136  */
1137
1138 static AssemblyEnv*
1139 NewAssemblyEnv(
1140     CompileEnv* envPtr,         /* Compilation environment being used for code
1141                                  * generation*/
1142     int flags)                  /* Compilation flags (TCL_EVAL_DIRECT) */
1143 {
1144     Tcl_Interp* interp = (Tcl_Interp*) envPtr->iPtr;
1145                                 /* Tcl interpreter */
1146     AssemblyEnv* assemEnvPtr = (AssemblyEnv*)TclStackAlloc(interp, sizeof(AssemblyEnv));
1147                                 /* Assembler environment under construction */
1148     Tcl_Parse* parsePtr = (Tcl_Parse*)TclStackAlloc(interp, sizeof(Tcl_Parse));
1149                                 /* Parse of one line of assembly code */
1150
1151     assemEnvPtr->envPtr = envPtr;
1152     assemEnvPtr->parsePtr = parsePtr;
1153     assemEnvPtr->cmdLine = 1;
1154     assemEnvPtr->clNext = envPtr->clNext;
1155
1156     /*
1157      * Make the hashtables that store symbol resolution.
1158      */
1159
1160     Tcl_InitHashTable(&assemEnvPtr->labelHash, TCL_STRING_KEYS);
1161
1162     /*
1163      * Start the first basic block.
1164      */
1165
1166     assemEnvPtr->curr_bb = NULL;
1167     assemEnvPtr->head_bb = AllocBB(assemEnvPtr);
1168     assemEnvPtr->curr_bb = assemEnvPtr->head_bb;
1169     assemEnvPtr->head_bb->startLine = 1;
1170
1171     /*
1172      * Stash compilation flags.
1173      */
1174
1175     assemEnvPtr->flags = flags;
1176     return assemEnvPtr;
1177 }
1178 \f
1179 /*
1180  *-----------------------------------------------------------------------------
1181  *
1182  * FreeAssemblyEnv --
1183  *
1184  *      Cleans up the assembler environment when assembly is complete.
1185  *
1186  *-----------------------------------------------------------------------------
1187  */
1188
1189 static void
1190 FreeAssemblyEnv(
1191     AssemblyEnv* assemEnvPtr)   /* Environment to free */
1192 {
1193     CompileEnv* envPtr = assemEnvPtr->envPtr;
1194                                 /* Compilation environment being used for code
1195                                  * generation */
1196     Tcl_Interp* interp = (Tcl_Interp*) envPtr->iPtr;
1197                                 /* Tcl interpreter */
1198     BasicBlock* thisBB;         /* Pointer to a basic block being deleted */
1199     BasicBlock* nextBB;         /* Pointer to a deleted basic block's
1200                                  * successor */
1201
1202     /*
1203      * Free all the basic block structures.
1204      */
1205
1206     for (thisBB = assemEnvPtr->head_bb; thisBB != NULL; thisBB = nextBB) {
1207         if (thisBB->jumpTarget != NULL) {
1208             Tcl_DecrRefCount(thisBB->jumpTarget);
1209         }
1210         if (thisBB->foreignExceptions != NULL) {
1211             ckfree(thisBB->foreignExceptions);
1212         }
1213         nextBB = thisBB->successor1;
1214         if (thisBB->jtPtr != NULL) {
1215             DeleteMirrorJumpTable(thisBB->jtPtr);
1216             thisBB->jtPtr = NULL;
1217         }
1218         ckfree(thisBB);
1219     }
1220
1221     /*
1222      * Dispose what's left.
1223      */
1224
1225     Tcl_DeleteHashTable(&assemEnvPtr->labelHash);
1226     TclStackFree(interp, assemEnvPtr->parsePtr);
1227     TclStackFree(interp, assemEnvPtr);
1228 }
1229 \f
1230 /*
1231  *-----------------------------------------------------------------------------
1232  *
1233  * AssembleOneLine --
1234  *
1235  *      Assembles a single command from an assembly language source.
1236  *
1237  * Results:
1238  *      Returns TCL_ERROR with an appropriate error message if the assembly
1239  *      fails. Returns TCL_OK if the assembly succeeds. Updates the assembly
1240  *      environment with the state of the assembly.
1241  *
1242  *-----------------------------------------------------------------------------
1243  */
1244
1245 static int
1246 AssembleOneLine(
1247     AssemblyEnv* assemEnvPtr)   /* State of the assembly */
1248 {
1249     CompileEnv* envPtr = assemEnvPtr->envPtr;
1250                                 /* Compilation environment being used for code
1251                                  * gen */
1252     Tcl_Interp* interp = (Tcl_Interp*) envPtr->iPtr;
1253                                 /* Tcl interpreter */
1254     Tcl_Parse* parsePtr = assemEnvPtr->parsePtr;
1255                                 /* Parse of the line of code */
1256     Tcl_Token* tokenPtr;        /* Current token within the line of code */
1257     Tcl_Obj* instNameObj;       /* Name of the instruction */
1258     int tblIdx;                 /* Index in TalInstructionTable of the
1259                                  * instruction */
1260     enum TalInstType instType;  /* Type of the instruction */
1261     Tcl_Obj* operand1Obj = NULL;
1262                                 /* First operand to the instruction */
1263     const char* operand1;       /* String rep of the operand */
1264     int operand1Len;            /* String length of the operand */
1265     int opnd;                   /* Integer representation of an operand */
1266     int litIndex;               /* Literal pool index of a constant */
1267     int localVar;               /* LVT index of a local variable */
1268     int flags;                  /* Flags for a basic block */
1269     JumptableInfo* jtPtr;       /* Pointer to a jumptable */
1270     int infoIndex;              /* Index of the jumptable in auxdata */
1271     int status = TCL_ERROR;     /* Return value from this function */
1272
1273     /*
1274      * Make sure that the instruction name is known at compile time.
1275      */
1276
1277     tokenPtr = parsePtr->tokenPtr;
1278     if (GetNextOperand(assemEnvPtr, &tokenPtr, &instNameObj) != TCL_OK) {
1279         return TCL_ERROR;
1280     }
1281
1282     /*
1283      * Look up the instruction name.
1284      */
1285
1286     if (Tcl_GetIndexFromObjStruct(interp, instNameObj,
1287             &TalInstructionTable[0].name, sizeof(TalInstDesc), "instruction",
1288             TCL_EXACT, &tblIdx) != TCL_OK) {
1289         goto cleanup;
1290     }
1291
1292     /*
1293      * Vector on the type of instruction being processed.
1294      */
1295
1296     instType = TalInstructionTable[tblIdx].instType;
1297     switch (instType) {
1298
1299     case ASSEM_PUSH:
1300         if (parsePtr->numWords != 2) {
1301             Tcl_WrongNumArgs(interp, 1, &instNameObj, "value");
1302             goto cleanup;
1303         }
1304         if (GetNextOperand(assemEnvPtr, &tokenPtr, &operand1Obj) != TCL_OK) {
1305             goto cleanup;
1306         }
1307         operand1 = Tcl_GetStringFromObj(operand1Obj, &operand1Len);
1308         litIndex = TclRegisterNewLiteral(envPtr, operand1, operand1Len);
1309         BBEmitInst1or4(assemEnvPtr, tblIdx, litIndex, 0);
1310         break;
1311
1312     case ASSEM_1BYTE:
1313         if (parsePtr->numWords != 1) {
1314             Tcl_WrongNumArgs(interp, 1, &instNameObj, "");
1315             goto cleanup;
1316         }
1317         BBEmitOpcode(assemEnvPtr, tblIdx, 0);
1318         break;
1319
1320     case ASSEM_BEGIN_CATCH:
1321         /*
1322          * Emit the BEGIN_CATCH instruction with the code offset of the
1323          * exception branch target instead of the exception range index. The
1324          * correct index will be generated and inserted later, when catches
1325          * are being resolved.
1326          */
1327
1328         if (parsePtr->numWords != 2) {
1329             Tcl_WrongNumArgs(interp, 1, &instNameObj, "label");
1330             goto cleanup;
1331         }
1332         if (GetNextOperand(assemEnvPtr, &tokenPtr, &operand1Obj) != TCL_OK) {
1333             goto cleanup;
1334         }
1335         assemEnvPtr->curr_bb->jumpLine = assemEnvPtr->cmdLine;
1336         assemEnvPtr->curr_bb->jumpOffset = envPtr->codeNext-envPtr->codeStart;
1337         BBEmitInstInt4(assemEnvPtr, tblIdx, 0, 0);
1338         assemEnvPtr->curr_bb->flags |= BB_BEGINCATCH;
1339         StartBasicBlock(assemEnvPtr, BB_FALLTHRU, operand1Obj);
1340         break;
1341
1342     case ASSEM_BOOL:
1343         if (parsePtr->numWords != 2) {
1344             Tcl_WrongNumArgs(interp, 1, &instNameObj, "boolean");
1345             goto cleanup;
1346         }
1347         if (GetBooleanOperand(assemEnvPtr, &tokenPtr, &opnd) != TCL_OK) {
1348             goto cleanup;
1349         }
1350         BBEmitInstInt1(assemEnvPtr, tblIdx, opnd, 0);
1351         break;
1352
1353     case ASSEM_BOOL_LVT4:
1354         if (parsePtr->numWords != 3) {
1355             Tcl_WrongNumArgs(interp, 1, &instNameObj, "boolean varName");
1356             goto cleanup;
1357         }
1358         if (GetBooleanOperand(assemEnvPtr, &tokenPtr, &opnd) != TCL_OK) {
1359             goto cleanup;
1360         }
1361         localVar = FindLocalVar(assemEnvPtr, &tokenPtr);
1362         if (localVar < 0) {
1363             goto cleanup;
1364         }
1365         BBEmitInstInt1(assemEnvPtr, tblIdx, opnd, 0);
1366         TclEmitInt4(localVar, envPtr);
1367         break;
1368
1369     case ASSEM_CLOCK_READ:
1370         if (parsePtr->numWords != 2) {
1371             Tcl_WrongNumArgs(interp, 1, &instNameObj, "imm8");
1372             goto cleanup;
1373         }
1374         if (GetIntegerOperand(assemEnvPtr, &tokenPtr, &opnd) != TCL_OK) {
1375             goto cleanup;
1376         }
1377         if (opnd < 0 || opnd > 3) {
1378             Tcl_SetObjResult(interp,
1379                              Tcl_NewStringObj("operand must be [0..3]", -1));
1380             Tcl_SetErrorCode(interp, "TCL", "ASSEM", "OPERAND<0,>3", NULL);
1381             goto cleanup;
1382         }
1383         BBEmitInstInt1(assemEnvPtr, tblIdx, opnd, opnd);
1384         break;
1385
1386     case ASSEM_CONCAT1:
1387         if (parsePtr->numWords != 2) {
1388             Tcl_WrongNumArgs(interp, 1, &instNameObj, "imm8");
1389             goto cleanup;
1390         }
1391         if (GetIntegerOperand(assemEnvPtr, &tokenPtr, &opnd) != TCL_OK
1392                 || CheckOneByte(interp, opnd) != TCL_OK
1393                 || CheckStrictlyPositive(interp, opnd) != TCL_OK) {
1394             goto cleanup;
1395         }
1396         BBEmitInstInt1(assemEnvPtr, tblIdx, opnd, opnd);
1397         break;
1398
1399     case ASSEM_DICT_GET:
1400         if (parsePtr->numWords != 2) {
1401             Tcl_WrongNumArgs(interp, 1, &instNameObj, "count");
1402             goto cleanup;
1403         }
1404         if (GetIntegerOperand(assemEnvPtr, &tokenPtr, &opnd) != TCL_OK
1405                 || CheckStrictlyPositive(interp, opnd) != TCL_OK) {
1406             goto cleanup;
1407         }
1408         BBEmitInstInt4(assemEnvPtr, tblIdx, opnd, opnd+1);
1409         break;
1410
1411     case ASSEM_DICT_SET:
1412         if (parsePtr->numWords != 3) {
1413             Tcl_WrongNumArgs(interp, 1, &instNameObj, "count varName");
1414             goto cleanup;
1415         }
1416         if (GetIntegerOperand(assemEnvPtr, &tokenPtr, &opnd) != TCL_OK
1417                 || CheckStrictlyPositive(interp, opnd) != TCL_OK) {
1418             goto cleanup;
1419         }
1420         localVar = FindLocalVar(assemEnvPtr, &tokenPtr);
1421         if (localVar < 0) {
1422             goto cleanup;
1423         }
1424         BBEmitInstInt4(assemEnvPtr, tblIdx, opnd, opnd+1);
1425         TclEmitInt4(localVar, envPtr);
1426         break;
1427
1428     case ASSEM_DICT_UNSET:
1429         if (parsePtr->numWords != 3) {
1430             Tcl_WrongNumArgs(interp, 1, &instNameObj, "count varName");
1431             goto cleanup;
1432         }
1433         if (GetIntegerOperand(assemEnvPtr, &tokenPtr, &opnd) != TCL_OK
1434                 || CheckStrictlyPositive(interp, opnd) != TCL_OK) {
1435             goto cleanup;
1436         }
1437         localVar = FindLocalVar(assemEnvPtr, &tokenPtr);
1438         if (localVar < 0) {
1439             goto cleanup;
1440         }
1441         BBEmitInstInt4(assemEnvPtr, tblIdx, opnd, opnd);
1442         TclEmitInt4(localVar, envPtr);
1443         break;
1444
1445     case ASSEM_END_CATCH:
1446         if (parsePtr->numWords != 1) {
1447             Tcl_WrongNumArgs(interp, 1, &instNameObj, "");
1448             goto cleanup;
1449         }
1450         assemEnvPtr->curr_bb->flags |= BB_ENDCATCH;
1451         BBEmitOpcode(assemEnvPtr, tblIdx, 0);
1452         StartBasicBlock(assemEnvPtr, BB_FALLTHRU, NULL);
1453         break;
1454
1455     case ASSEM_EVAL:
1456         /* TODO - Refactor this stuff into a subroutine that takes the inst
1457          * code, the message ("script" or "expression") and an evaluator
1458          * callback that calls TclCompileScript or TclCompileExpr. */
1459
1460         if (parsePtr->numWords != 2) {
1461             Tcl_WrongNumArgs(interp, 1, &instNameObj,
1462                     ((TalInstructionTable[tblIdx].tclInstCode
1463                     == INST_EVAL_STK) ? "script" : "expression"));
1464             goto cleanup;
1465         }
1466         if (tokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
1467             CompileEmbeddedScript(assemEnvPtr, tokenPtr+1,
1468                     TalInstructionTable+tblIdx);
1469         } else if (GetNextOperand(assemEnvPtr, &tokenPtr,
1470                 &operand1Obj) != TCL_OK) {
1471             goto cleanup;
1472         } else {
1473             operand1 = Tcl_GetStringFromObj(operand1Obj, &operand1Len);
1474             litIndex = TclRegisterNewLiteral(envPtr, operand1, operand1Len);
1475
1476             /*
1477              * Assumes that PUSH is the first slot!
1478              */
1479
1480             BBEmitInst1or4(assemEnvPtr, 0, litIndex, 0);
1481             BBEmitOpcode(assemEnvPtr, tblIdx, 0);
1482         }
1483         break;
1484
1485     case ASSEM_INVOKE:
1486         if (parsePtr->numWords != 2) {
1487             Tcl_WrongNumArgs(interp, 1, &instNameObj, "count");
1488             goto cleanup;
1489         }
1490         if (GetIntegerOperand(assemEnvPtr, &tokenPtr, &opnd) != TCL_OK
1491                 || CheckStrictlyPositive(interp, opnd) != TCL_OK) {
1492             goto cleanup;
1493         }
1494
1495         BBEmitInst1or4(assemEnvPtr, tblIdx, opnd, opnd);
1496         break;
1497
1498     case ASSEM_JUMP:
1499     case ASSEM_JUMP4:
1500         if (parsePtr->numWords != 2) {
1501             Tcl_WrongNumArgs(interp, 1, &instNameObj, "label");
1502             goto cleanup;
1503         }
1504         if (GetNextOperand(assemEnvPtr, &tokenPtr, &operand1Obj) != TCL_OK) {
1505             goto cleanup;
1506         }
1507         assemEnvPtr->curr_bb->jumpOffset = envPtr->codeNext-envPtr->codeStart;
1508         if (instType == ASSEM_JUMP) {
1509             flags = BB_JUMP1;
1510             BBEmitInstInt1(assemEnvPtr, tblIdx, 0, 0);
1511         } else {
1512             flags = 0;
1513             BBEmitInstInt4(assemEnvPtr, tblIdx, 0, 0);
1514         }
1515
1516         /*
1517          * Start a new basic block at the instruction following the jump.
1518          */
1519
1520         assemEnvPtr->curr_bb->jumpLine = assemEnvPtr->cmdLine;
1521         if (TalInstructionTable[tblIdx].operandsConsumed != 0) {
1522             flags |= BB_FALLTHRU;
1523         }
1524         StartBasicBlock(assemEnvPtr, flags, operand1Obj);
1525         break;
1526
1527     case ASSEM_JUMPTABLE:
1528         if (parsePtr->numWords != 2) {
1529             Tcl_WrongNumArgs(interp, 1, &instNameObj, "table");
1530             goto cleanup;
1531         }
1532         if (GetNextOperand(assemEnvPtr, &tokenPtr, &operand1Obj) != TCL_OK) {
1533             goto cleanup;
1534         }
1535
1536         jtPtr = (JumptableInfo*)ckalloc(sizeof(JumptableInfo));
1537
1538         Tcl_InitHashTable(&jtPtr->hashTable, TCL_STRING_KEYS);
1539         assemEnvPtr->curr_bb->jumpLine = assemEnvPtr->cmdLine;
1540         assemEnvPtr->curr_bb->jumpOffset = envPtr->codeNext-envPtr->codeStart;
1541         DEBUG_PRINT("bb %p jumpLine %d jumpOffset %d\n",
1542                 assemEnvPtr->curr_bb, assemEnvPtr->cmdLine,
1543                 envPtr->codeNext - envPtr->codeStart);
1544
1545         infoIndex = TclCreateAuxData(jtPtr, &tclJumptableInfoType, envPtr);
1546         DEBUG_PRINT("auxdata index=%d\n", infoIndex);
1547
1548         BBEmitInstInt4(assemEnvPtr, tblIdx, infoIndex, 0);
1549         if (CreateMirrorJumpTable(assemEnvPtr, operand1Obj) != TCL_OK) {
1550             goto cleanup;
1551         }
1552         StartBasicBlock(assemEnvPtr, BB_JUMPTABLE|BB_FALLTHRU, NULL);
1553         break;
1554
1555     case ASSEM_LABEL:
1556         if (parsePtr->numWords != 2) {
1557             Tcl_WrongNumArgs(interp, 1, &instNameObj, "name");
1558             goto cleanup;
1559         }
1560         if (GetNextOperand(assemEnvPtr, &tokenPtr, &operand1Obj) != TCL_OK) {
1561             goto cleanup;
1562         }
1563
1564         /*
1565          * Add the (label_name, address) pair to the hash table.
1566          */
1567
1568         if (DefineLabel(assemEnvPtr, Tcl_GetString(operand1Obj)) != TCL_OK) {
1569             goto cleanup;
1570         }
1571         break;
1572
1573     case ASSEM_LINDEX_MULTI:
1574         if (parsePtr->numWords != 2) {
1575             Tcl_WrongNumArgs(interp, 1, &instNameObj, "count");
1576             goto cleanup;
1577         }
1578         if (GetIntegerOperand(assemEnvPtr, &tokenPtr, &opnd) != TCL_OK
1579                 || CheckStrictlyPositive(interp, opnd) != TCL_OK) {
1580             goto cleanup;
1581         }
1582         BBEmitInstInt4(assemEnvPtr, tblIdx, opnd, opnd);
1583         break;
1584
1585     case ASSEM_LIST:
1586         if (parsePtr->numWords != 2) {
1587             Tcl_WrongNumArgs(interp, 1, &instNameObj, "count");
1588             goto cleanup;
1589         }
1590         if (GetIntegerOperand(assemEnvPtr, &tokenPtr, &opnd) != TCL_OK
1591                 || CheckNonNegative(interp, opnd) != TCL_OK) {
1592             goto cleanup;
1593         }
1594         BBEmitInstInt4(assemEnvPtr, tblIdx, opnd, opnd);
1595         break;
1596
1597     case ASSEM_INDEX:
1598         if (parsePtr->numWords != 2) {
1599             Tcl_WrongNumArgs(interp, 1, &instNameObj, "count");
1600             goto cleanup;
1601         }
1602         if (GetListIndexOperand(assemEnvPtr, &tokenPtr, &opnd) != TCL_OK) {
1603             goto cleanup;
1604         }
1605         BBEmitInstInt4(assemEnvPtr, tblIdx, opnd, opnd);
1606         break;
1607
1608     case ASSEM_LSET_FLAT:
1609         if (parsePtr->numWords != 2) {
1610             Tcl_WrongNumArgs(interp, 1, &instNameObj, "count");
1611             goto cleanup;
1612         }
1613         if (GetIntegerOperand(assemEnvPtr, &tokenPtr, &opnd) != TCL_OK) {
1614             goto cleanup;
1615         }
1616         if (opnd < 2) {
1617             if (assemEnvPtr->flags & TCL_EVAL_DIRECT) {
1618                 Tcl_SetObjResult(interp,
1619                         Tcl_NewStringObj("operand must be >=2", -1));
1620                 Tcl_SetErrorCode(interp, "TCL", "ASSEM", "OPERAND>=2", NULL);
1621             }
1622             goto cleanup;
1623         }
1624         BBEmitInstInt4(assemEnvPtr, tblIdx, opnd, opnd);
1625         break;
1626
1627     case ASSEM_LVT:
1628         if (parsePtr->numWords != 2) {
1629             Tcl_WrongNumArgs(interp, 1, &instNameObj, "varname");
1630             goto cleanup;
1631         }
1632         localVar = FindLocalVar(assemEnvPtr, &tokenPtr);
1633         if (localVar < 0) {
1634             goto cleanup;
1635         }
1636         BBEmitInst1or4(assemEnvPtr, tblIdx, localVar, 0);
1637         break;
1638
1639     case ASSEM_LVT1:
1640         if (parsePtr->numWords != 2) {
1641             Tcl_WrongNumArgs(interp, 1, &instNameObj, "varname");
1642             goto cleanup;
1643         }
1644         localVar = FindLocalVar(assemEnvPtr, &tokenPtr);
1645         if (localVar < 0 || CheckOneByte(interp, localVar)) {
1646             goto cleanup;
1647         }
1648         BBEmitInstInt1(assemEnvPtr, tblIdx, localVar, 0);
1649         break;
1650
1651     case ASSEM_LVT1_SINT1:
1652         if (parsePtr->numWords != 3) {
1653             Tcl_WrongNumArgs(interp, 1, &instNameObj, "varName imm8");
1654             goto cleanup;
1655         }
1656         localVar = FindLocalVar(assemEnvPtr, &tokenPtr);
1657         if (localVar < 0 || CheckOneByte(interp, localVar)
1658                 || GetIntegerOperand(assemEnvPtr, &tokenPtr, &opnd) != TCL_OK
1659                 || CheckSignedOneByte(interp, opnd)) {
1660             goto cleanup;
1661         }
1662         BBEmitInstInt1(assemEnvPtr, tblIdx, localVar, 0);
1663         TclEmitInt1(opnd, envPtr);
1664         break;
1665
1666     case ASSEM_LVT4:
1667         if (parsePtr->numWords != 2) {
1668             Tcl_WrongNumArgs(interp, 1, &instNameObj, "varname");
1669             goto cleanup;
1670         }
1671         localVar = FindLocalVar(assemEnvPtr, &tokenPtr);
1672         if (localVar < 0) {
1673             goto cleanup;
1674         }
1675         BBEmitInstInt4(assemEnvPtr, tblIdx, localVar, 0);
1676         break;
1677
1678     case ASSEM_OVER:
1679         if (parsePtr->numWords != 2) {
1680             Tcl_WrongNumArgs(interp, 1, &instNameObj, "count");
1681             goto cleanup;
1682         }
1683         if (GetIntegerOperand(assemEnvPtr, &tokenPtr, &opnd) != TCL_OK
1684                 || CheckNonNegative(interp, opnd) != TCL_OK) {
1685             goto cleanup;
1686         }
1687         BBEmitInstInt4(assemEnvPtr, tblIdx, opnd, opnd+1);
1688         break;
1689
1690     case ASSEM_REGEXP:
1691         if (parsePtr->numWords != 2) {
1692             Tcl_WrongNumArgs(interp, 1, &instNameObj, "boolean");
1693             goto cleanup;
1694         }
1695         if (GetBooleanOperand(assemEnvPtr, &tokenPtr, &opnd) != TCL_OK) {
1696             goto cleanup;
1697         }
1698         {
1699             BBEmitInstInt1(assemEnvPtr, tblIdx, TCL_REG_ADVANCED | (opnd ? TCL_REG_NOCASE : 0), 0);
1700         }
1701         break;
1702
1703     case ASSEM_REVERSE:
1704         if (parsePtr->numWords != 2) {
1705             Tcl_WrongNumArgs(interp, 1, &instNameObj, "count");
1706             goto cleanup;
1707         }
1708         if (GetIntegerOperand(assemEnvPtr, &tokenPtr, &opnd) != TCL_OK
1709                 || CheckNonNegative(interp, opnd) != TCL_OK) {
1710             goto cleanup;
1711         }
1712         BBEmitInstInt4(assemEnvPtr, tblIdx, opnd, opnd);
1713         break;
1714
1715     case ASSEM_SINT1:
1716         if (parsePtr->numWords != 2) {
1717             Tcl_WrongNumArgs(interp, 1, &instNameObj, "imm8");
1718             goto cleanup;
1719         }
1720         if (GetIntegerOperand(assemEnvPtr, &tokenPtr, &opnd) != TCL_OK
1721                 || CheckSignedOneByte(interp, opnd) != TCL_OK) {
1722             goto cleanup;
1723         }
1724         BBEmitInstInt1(assemEnvPtr, tblIdx, opnd, 0);
1725         break;
1726
1727     case ASSEM_SINT4_LVT4:
1728         if (parsePtr->numWords != 3) {
1729             Tcl_WrongNumArgs(interp, 1, &instNameObj, "count varName");
1730             goto cleanup;
1731         }
1732         if (GetIntegerOperand(assemEnvPtr, &tokenPtr, &opnd) != TCL_OK) {
1733             goto cleanup;
1734         }
1735         localVar = FindLocalVar(assemEnvPtr, &tokenPtr);
1736         if (localVar < 0) {
1737             goto cleanup;
1738         }
1739         BBEmitInstInt4(assemEnvPtr, tblIdx, opnd, 0);
1740         TclEmitInt4(localVar, envPtr);
1741         break;
1742
1743     default:
1744         Tcl_Panic("Instruction \"%s\" could not be found, can't happen\n",
1745                 Tcl_GetString(instNameObj));
1746     }
1747
1748     status = TCL_OK;
1749  cleanup:
1750     Tcl_DecrRefCount(instNameObj);
1751     if (operand1Obj) {
1752         Tcl_DecrRefCount(operand1Obj);
1753     }
1754     return status;
1755 }
1756 \f
1757 /*
1758  *-----------------------------------------------------------------------------
1759  *
1760  * CompileEmbeddedScript --
1761  *
1762  *      Compile an embedded 'eval' or 'expr' that appears in assembly code.
1763  *
1764  * This procedure is called when the 'eval' or 'expr' assembly directive is
1765  * encountered, and the argument to the directive is a simple word that
1766  * requires no substitution. The appropriate compiler (TclCompileScript or
1767  * TclCompileExpr) is invoked recursively, and emits bytecode.
1768  *
1769  * Before the compiler is invoked, the compilation environment's stack
1770  * consumption is reset to zero. Upon return from the compilation, the net
1771  * stack effect of the compilation is in the compiler env, and this stack
1772  * effect is posted to the assembler environment. The compile environment's
1773  * stack consumption is then restored to what it was before (which is actually
1774  * the state of the stack on entry to the block of assembly code).
1775  *
1776  * Any exception ranges pushed by the compilation are copied to the basic
1777  * block and removed from the compiler environment. They will be rebuilt at
1778  * the end of assembly, when the exception stack depth is actually known.
1779  *
1780  *-----------------------------------------------------------------------------
1781  */
1782
1783 static void
1784 CompileEmbeddedScript(
1785     AssemblyEnv* assemEnvPtr,   /* Assembly environment */
1786     Tcl_Token* tokenPtr,        /* Tcl_Token containing the script */
1787     const TalInstDesc* instPtr) /* Instruction that determines whether
1788                                  * the script is 'expr' or 'eval' */
1789 {
1790     CompileEnv* envPtr = assemEnvPtr->envPtr;
1791                                 /* Compilation environment */
1792     Tcl_Interp* interp = (Tcl_Interp*) envPtr->iPtr;
1793                                 /* Tcl interpreter */
1794
1795     /*
1796      * The expression or script is not only known at compile time, but
1797      * actually a "simple word". It can be compiled inline by invoking the
1798      * compiler recursively.
1799      *
1800      * Save away the stack depth and reset it before compiling the script.
1801      * We'll record the stack usage of the script in the BasicBlock, and
1802      * accumulate it together with the stack usage of the enclosing assembly
1803      * code.
1804      */
1805
1806     int savedStackDepth = envPtr->currStackDepth;
1807     int savedMaxStackDepth = envPtr->maxStackDepth;
1808     int savedExceptArrayNext = envPtr->exceptArrayNext;
1809
1810     envPtr->currStackDepth = 0;
1811     envPtr->maxStackDepth = 0;
1812
1813     StartBasicBlock(assemEnvPtr, BB_FALLTHRU, NULL);
1814     switch(instPtr->tclInstCode) {
1815     case INST_EVAL_STK:
1816         TclCompileScript(interp, tokenPtr->start, tokenPtr->size, envPtr);
1817         break;
1818     case INST_EXPR_STK:
1819         TclCompileExpr(interp, tokenPtr->start, tokenPtr->size, envPtr, 1);
1820         break;
1821     default:
1822         Tcl_Panic("no ASSEM_EVAL case for %s (%d), can't happen",
1823                 instPtr->name, instPtr->tclInstCode);
1824     }
1825
1826     /*
1827      * Roll up the stack usage of the embedded block into the assembler
1828      * environment.
1829      */
1830
1831     SyncStackDepth(assemEnvPtr);
1832     envPtr->currStackDepth = savedStackDepth;
1833     envPtr->maxStackDepth = savedMaxStackDepth;
1834
1835     /*
1836      * Save any exception ranges that were pushed by the compiler; they will
1837      * need to be fixed up once the stack depth is known.
1838      */
1839
1840     MoveExceptionRangesToBasicBlock(assemEnvPtr, savedExceptArrayNext);
1841
1842     /*
1843      * Flush the current basic block.
1844      */
1845
1846     StartBasicBlock(assemEnvPtr, BB_FALLTHRU, NULL);
1847 }
1848 \f
1849 /*
1850  *-----------------------------------------------------------------------------
1851  *
1852  * SyncStackDepth --
1853  *
1854  *      Copies the stack depth from the compile environment to a basic block.
1855  *
1856  * Side effects:
1857  *      Current and max stack depth in the current basic block are adjusted.
1858  *
1859  * This procedure is called on return from invoking the compiler for the
1860  * 'eval' and 'expr' operations. It adjusts the stack depth of the current
1861  * basic block to reflect the stack required by the just-compiled code.
1862  *
1863  *-----------------------------------------------------------------------------
1864  */
1865
1866 static void
1867 SyncStackDepth(
1868     AssemblyEnv* assemEnvPtr)   /* Assembly environment */
1869 {
1870     CompileEnv* envPtr = assemEnvPtr->envPtr;
1871                                 /* Compilation environment */
1872     BasicBlock* curr_bb = assemEnvPtr->curr_bb;
1873                                 /* Current basic block */
1874     int maxStackDepth = curr_bb->finalStackDepth + envPtr->maxStackDepth;
1875                                 /* Max stack depth in the basic block */
1876
1877     if (maxStackDepth > curr_bb->maxStackDepth) {
1878         curr_bb->maxStackDepth = maxStackDepth;
1879     }
1880     curr_bb->finalStackDepth += envPtr->currStackDepth;
1881 }
1882 \f
1883 /*
1884  *-----------------------------------------------------------------------------
1885  *
1886  * MoveExceptionRangesToBasicBlock --
1887  *
1888  *      Removes exception ranges that were created by compiling an embedded
1889  *      script from the CompileEnv, and stores them in the BasicBlock. They
1890  *      will be reinstalled, at the correct stack depth, after control flow
1891  *      analysis is complete on the assembly code.
1892  *
1893  *-----------------------------------------------------------------------------
1894  */
1895
1896 static void
1897 MoveExceptionRangesToBasicBlock(
1898     AssemblyEnv* assemEnvPtr,   /* Assembly environment */
1899     int savedExceptArrayNext)   /* Saved index of the end of the exception
1900                                  * range array */
1901 {
1902     CompileEnv* envPtr = assemEnvPtr->envPtr;
1903                                 /* Compilation environment */
1904     BasicBlock* curr_bb = assemEnvPtr->curr_bb;
1905                                 /* Current basic block */
1906     int exceptionCount = envPtr->exceptArrayNext - savedExceptArrayNext;
1907                                 /* Number of ranges that must be moved */
1908     int i;
1909
1910     if (exceptionCount == 0) {
1911         /* Nothing to do */
1912         return;
1913     }
1914
1915     /*
1916      * Save the exception ranges in the basic block. They will be re-added at
1917      * the conclusion of assembly; at this time, the INST_BEGIN_CATCH
1918      * instructions in the block will be adjusted from whatever range indices
1919      * they have [savedExceptArrayNext .. envPtr->exceptArrayNext) to the
1920      * indices that the exceptions acquire. The saved exception ranges are
1921      * converted to a relative nesting depth. The depth will be recomputed
1922      * once flow analysis has determined the actual stack depth of the block.
1923      */
1924
1925     DEBUG_PRINT("basic block %p has %d exceptions starting at %d\n",
1926             curr_bb, exceptionCount, savedExceptArrayNext);
1927     curr_bb->foreignExceptionBase = savedExceptArrayNext;
1928     curr_bb->foreignExceptionCount = exceptionCount;
1929     curr_bb->foreignExceptions =
1930                 (ExceptionRange*)ckalloc(exceptionCount * sizeof(ExceptionRange));
1931     memcpy(curr_bb->foreignExceptions,
1932             envPtr->exceptArrayPtr + savedExceptArrayNext,
1933             exceptionCount * sizeof(ExceptionRange));
1934     for (i = 0; i < exceptionCount; ++i) {
1935         curr_bb->foreignExceptions[i].nestingLevel -= envPtr->exceptDepth;
1936     }
1937     envPtr->exceptArrayNext = savedExceptArrayNext;
1938 }
1939 \f
1940 /*
1941  *-----------------------------------------------------------------------------
1942  *
1943  * CreateMirrorJumpTable --
1944  *
1945  *      Makes a jump table with comparison values and assembly code labels.
1946  *
1947  * Results:
1948  *      Returns a standard Tcl status, with an error message in the
1949  *      interpreter on error.
1950  *
1951  * Side effects:
1952  *      Initializes the jump table pointer in the current basic block to a
1953  *      JumptableInfo. The keys in the JumptableInfo are the comparison
1954  *      strings. The values, instead of being jump displacements, are
1955  *      Tcl_Obj's with the code labels.
1956  */
1957
1958 static int
1959 CreateMirrorJumpTable(
1960     AssemblyEnv* assemEnvPtr,   /* Assembly environment */
1961     Tcl_Obj* jumps)             /* List of alternating keywords and labels */
1962 {
1963     int objc;                   /* Number of elements in the 'jumps' list */
1964     Tcl_Obj** objv;             /* Pointers to the elements in the list */
1965     CompileEnv* envPtr = assemEnvPtr->envPtr;
1966                                 /* Compilation environment */
1967     Tcl_Interp* interp = (Tcl_Interp*) envPtr->iPtr;
1968                                 /* Tcl interpreter */
1969     BasicBlock* bbPtr = assemEnvPtr->curr_bb;
1970                                 /* Current basic block */
1971     JumptableInfo* jtPtr;
1972     Tcl_HashTable* jtHashPtr;   /* Hashtable in the JumptableInfo */
1973     Tcl_HashEntry* hashEntry;   /* Entry for a key in the hashtable */
1974     int isNew;                  /* Flag==1 if the key is not yet in the
1975                                  * table. */
1976     int i;
1977
1978     if (Tcl_ListObjGetElements(interp, jumps, &objc, &objv) != TCL_OK) {
1979         return TCL_ERROR;
1980     }
1981     if (objc % 2 != 0) {
1982         if (assemEnvPtr->flags & TCL_EVAL_DIRECT) {
1983             Tcl_SetObjResult(interp, Tcl_NewStringObj(
1984                     "jump table must have an even number of list elements",
1985                     -1));
1986             Tcl_SetErrorCode(interp, "TCL", "ASSEM", "BADJUMPTABLE", NULL);
1987         }
1988         return TCL_ERROR;
1989     }
1990
1991     /*
1992      * Allocate the jumptable.
1993      */
1994
1995     jtPtr = (JumptableInfo*)ckalloc(sizeof(JumptableInfo));
1996     jtHashPtr = &jtPtr->hashTable;
1997     Tcl_InitHashTable(jtHashPtr, TCL_STRING_KEYS);
1998
1999     /*
2000      * Fill the keys and labels into the table.
2001      */
2002
2003     DEBUG_PRINT("jump table {\n");
2004     for (i = 0; i < objc; i+=2) {
2005         DEBUG_PRINT("  %s -> %s\n", Tcl_GetString(objv[i]),
2006                 Tcl_GetString(objv[i+1]));
2007         hashEntry = Tcl_CreateHashEntry(jtHashPtr, Tcl_GetString(objv[i]),
2008                 &isNew);
2009         if (!isNew) {
2010             if (assemEnvPtr->flags & TCL_EVAL_DIRECT) {
2011                 Tcl_SetObjResult(interp, Tcl_ObjPrintf(
2012                         "duplicate entry in jump table for \"%s\"",
2013                         Tcl_GetString(objv[i])));
2014                 Tcl_SetErrorCode(interp, "TCL", "ASSEM", "DUPJUMPTABLEENTRY");
2015                 DeleteMirrorJumpTable(jtPtr);
2016                 return TCL_ERROR;
2017             }
2018         }
2019         Tcl_SetHashValue(hashEntry, objv[i+1]);
2020         Tcl_IncrRefCount(objv[i+1]);
2021     }
2022     DEBUG_PRINT("}\n");
2023
2024     /*
2025      * Put the mirror jumptable in the basic block struct.
2026      */
2027
2028     bbPtr->jtPtr = jtPtr;
2029     return TCL_OK;
2030 }
2031 \f
2032 /*
2033  *-----------------------------------------------------------------------------
2034  *
2035  * DeleteMirrorJumpTable --
2036  *
2037  *      Cleans up a jump table when the basic block is deleted.
2038  *
2039  *-----------------------------------------------------------------------------
2040  */
2041
2042 static void
2043 DeleteMirrorJumpTable(
2044     JumptableInfo* jtPtr)
2045 {
2046     Tcl_HashTable* jtHashPtr = &jtPtr->hashTable;
2047                                 /* Hash table pointer */
2048     Tcl_HashSearch search;      /* Hash search control */
2049     Tcl_HashEntry* entry;       /* Hash table entry containing a jump label */
2050     Tcl_Obj* label;             /* Jump label from the hash table */
2051
2052     for (entry = Tcl_FirstHashEntry(jtHashPtr, &search);
2053             entry != NULL;
2054             entry = Tcl_NextHashEntry(&search)) {
2055         label = (Tcl_Obj*)Tcl_GetHashValue(entry);
2056         Tcl_DecrRefCount(label);
2057         Tcl_SetHashValue(entry, NULL);
2058     }
2059     Tcl_DeleteHashTable(jtHashPtr);
2060     ckfree(jtPtr);
2061 }
2062 \f
2063 /*
2064  *-----------------------------------------------------------------------------
2065  *
2066  * GetNextOperand --
2067  *
2068  *      Retrieves the next operand in sequence from an assembly instruction,
2069  *      and makes sure that its value is known at compile time.
2070  *
2071  * Results:
2072  *      If successful, returns TCL_OK and leaves a Tcl_Obj with the operand
2073  *      text in *operandObjPtr. In case of failure, returns TCL_ERROR and
2074  *      leaves *operandObjPtr untouched.
2075  *
2076  * Side effects:
2077  *      Advances *tokenPtrPtr around the token just processed.
2078  *
2079  *-----------------------------------------------------------------------------
2080  */
2081
2082 static int
2083 GetNextOperand(
2084     AssemblyEnv* assemEnvPtr,   /* Assembly environment */
2085     Tcl_Token** tokenPtrPtr,    /* INPUT/OUTPUT: Pointer to the token holding
2086                                  * the operand */
2087     Tcl_Obj** operandObjPtr)    /* OUTPUT: Tcl object holding the operand text
2088                                  * with \-substitutions done. */
2089 {
2090     Tcl_Interp* interp = (Tcl_Interp*) assemEnvPtr->envPtr->iPtr;
2091     Tcl_Obj* operandObj;
2092
2093     TclNewObj(operandObj);
2094     if (!TclWordKnownAtCompileTime(*tokenPtrPtr, operandObj)) {
2095         Tcl_DecrRefCount(operandObj);
2096         if (assemEnvPtr->flags & TCL_EVAL_DIRECT) {
2097             Tcl_SetObjResult(interp, Tcl_NewStringObj(
2098                     "assembly code may not contain substitutions", -1));
2099             Tcl_SetErrorCode(interp, "TCL", "ASSEM", "NOSUBST", NULL);
2100         }
2101         return TCL_ERROR;
2102     }
2103     *tokenPtrPtr = TokenAfter(*tokenPtrPtr);
2104     Tcl_IncrRefCount(operandObj);
2105     *operandObjPtr = operandObj;
2106     return TCL_OK;
2107 }
2108 \f
2109 /*
2110  *-----------------------------------------------------------------------------
2111  *
2112  * GetBooleanOperand --
2113  *
2114  *      Retrieves a Boolean operand from the input stream and advances
2115  *      the token pointer.
2116  *
2117  * Results:
2118  *      Returns a standard Tcl result (with an error message in the
2119  *      interpreter on failure).
2120  *
2121  * Side effects:
2122  *      Stores the Boolean value in (*result) and advances (*tokenPtrPtr)
2123  *      to the next token.
2124  *
2125  *-----------------------------------------------------------------------------
2126  */
2127
2128 static int
2129 GetBooleanOperand(
2130     AssemblyEnv* assemEnvPtr,   /* Assembly environment */
2131     Tcl_Token** tokenPtrPtr,    /* Current token from the parser */
2132     int* result)                /* OUTPUT: Integer extracted from the token */
2133 {
2134     CompileEnv* envPtr = assemEnvPtr->envPtr;
2135                                 /* Compilation environment */
2136     Tcl_Interp* interp = (Tcl_Interp*) envPtr->iPtr;
2137                                 /* Tcl interpreter */
2138     Tcl_Token* tokenPtr = *tokenPtrPtr;
2139                                 /* INOUT: Pointer to the next token in the
2140                                  * source code */
2141     Tcl_Obj* intObj;            /* Integer from the source code */
2142     int status;                 /* Tcl status return */
2143
2144     /*
2145      * Extract the next token as a string.
2146      */
2147
2148     if (GetNextOperand(assemEnvPtr, tokenPtrPtr, &intObj) != TCL_OK) {
2149         return TCL_ERROR;
2150     }
2151
2152     /*
2153      * Convert to an integer, advance to the next token and return.
2154      */
2155
2156     status = Tcl_GetBooleanFromObj(interp, intObj, result);
2157     Tcl_DecrRefCount(intObj);
2158     *tokenPtrPtr = TokenAfter(tokenPtr);
2159     return status;
2160 }
2161 \f
2162 /*
2163  *-----------------------------------------------------------------------------
2164  *
2165  * GetIntegerOperand --
2166  *
2167  *      Retrieves an integer operand from the input stream and advances the
2168  *      token pointer.
2169  *
2170  * Results:
2171  *      Returns a standard Tcl result (with an error message in the
2172  *      interpreter on failure).
2173  *
2174  * Side effects:
2175  *      Stores the integer value in (*result) and advances (*tokenPtrPtr) to
2176  *      the next token.
2177  *
2178  *-----------------------------------------------------------------------------
2179  */
2180
2181 static int
2182 GetIntegerOperand(
2183     AssemblyEnv* assemEnvPtr,   /* Assembly environment */
2184     Tcl_Token** tokenPtrPtr,    /* Current token from the parser */
2185     int* result)                /* OUTPUT: Integer extracted from the token */
2186 {
2187     CompileEnv* envPtr = assemEnvPtr->envPtr;
2188                                 /* Compilation environment */
2189     Tcl_Interp* interp = (Tcl_Interp*) envPtr->iPtr;
2190                                 /* Tcl interpreter */
2191     Tcl_Token* tokenPtr = *tokenPtrPtr;
2192                                 /* INOUT: Pointer to the next token in the
2193                                  * source code */
2194     Tcl_Obj* intObj;            /* Integer from the source code */
2195     int status;                 /* Tcl status return */
2196
2197     /*
2198      * Extract the next token as a string.
2199      */
2200
2201     if (GetNextOperand(assemEnvPtr, tokenPtrPtr, &intObj) != TCL_OK) {
2202         return TCL_ERROR;
2203     }
2204
2205     /*
2206      * Convert to an integer, advance to the next token and return.
2207      */
2208
2209     status = Tcl_GetIntFromObj(interp, intObj, result);
2210     Tcl_DecrRefCount(intObj);
2211     *tokenPtrPtr = TokenAfter(tokenPtr);
2212     return status;
2213 }
2214 \f
2215 /*
2216  *-----------------------------------------------------------------------------
2217  *
2218  * GetListIndexOperand --
2219  *
2220  *      Gets the value of an operand intended to serve as a list index.
2221  *
2222  * Results:
2223  *      Returns a standard Tcl result: TCL_OK if the parse is successful and
2224  *      TCL_ERROR (with an appropriate error message) if the parse fails.
2225  *
2226  * Side effects:
2227  *      Stores the list index at '*index'. Values between -1 and 0x7FFFFFFF
2228  *      have their natural meaning; values between -2 and -0x80000000
2229  *      represent 'end-2-N'.
2230  *
2231  *-----------------------------------------------------------------------------
2232  */
2233
2234 static int
2235 GetListIndexOperand(
2236     AssemblyEnv* assemEnvPtr,   /* Assembly environment */
2237     Tcl_Token** tokenPtrPtr,    /* Current token from the parser */
2238     int* result)                /* OUTPUT: Integer extracted from the token */
2239 {
2240     CompileEnv* envPtr = assemEnvPtr->envPtr;
2241                                 /* Compilation environment */
2242     Tcl_Interp* interp = (Tcl_Interp*) envPtr->iPtr;
2243                                 /* Tcl interpreter */
2244     Tcl_Token* tokenPtr = *tokenPtrPtr;
2245                                 /* INOUT: Pointer to the next token in the
2246                                  * source code */
2247     Tcl_Obj *value;
2248     int status;
2249
2250     /* General operand validity check */
2251     if (GetNextOperand(assemEnvPtr, tokenPtrPtr, &value) != TCL_OK) {
2252         return TCL_ERROR;
2253     }
2254
2255     /* Convert to an integer, advance to the next token and return. */
2256     /*
2257      * NOTE: Indexing a list with an index before it yields the
2258      * same result as indexing after it, and might be more easily portable
2259      * when list size limits grow.
2260      */
2261     status = TclIndexEncode(interp, value,
2262             TCL_INDEX_BEFORE,TCL_INDEX_BEFORE, result);
2263
2264     Tcl_DecrRefCount(value);
2265     *tokenPtrPtr = TokenAfter(tokenPtr);
2266     return status;
2267 }
2268 \f
2269 /*
2270  *-----------------------------------------------------------------------------
2271  *
2272  * FindLocalVar --
2273  *
2274  *      Gets the name of a local variable from the input stream and advances
2275  *      the token pointer.
2276  *
2277  * Results:
2278  *      Returns the LVT index of the local variable.  Returns -1 if the
2279  *      variable is non-local, not known at compile time, or cannot be
2280  *      installed in the LVT (leaving an error message in the interpreter
2281  *      result if necessary).
2282  *
2283  * Side effects:
2284  *      Advances the token pointer.  May define a new LVT slot if the variable
2285  *      has not yet been seen and the execution context allows for it.
2286  *
2287  *-----------------------------------------------------------------------------
2288  */
2289
2290 static int
2291 FindLocalVar(
2292     AssemblyEnv* assemEnvPtr,   /* Assembly environment */
2293     Tcl_Token** tokenPtrPtr)
2294 {
2295     CompileEnv* envPtr = assemEnvPtr->envPtr;
2296                                 /* Compilation environment */
2297     Tcl_Interp* interp = (Tcl_Interp*) envPtr->iPtr;
2298                                 /* Tcl interpreter */
2299     Tcl_Token* tokenPtr = *tokenPtrPtr;
2300                                 /* INOUT: Pointer to the next token in the
2301                                  * source code. */
2302     Tcl_Obj* varNameObj;        /* Name of the variable */
2303     const char* varNameStr;
2304     int varNameLen;
2305     int localVar;               /* Index of the variable in the LVT */
2306
2307     if (GetNextOperand(assemEnvPtr, tokenPtrPtr, &varNameObj) != TCL_OK) {
2308         return -1;
2309     }
2310     varNameStr = Tcl_GetStringFromObj(varNameObj, &varNameLen);
2311     if (CheckNamespaceQualifiers(interp, varNameStr, varNameLen)) {
2312         Tcl_DecrRefCount(varNameObj);
2313         return -1;
2314     }
2315     localVar = TclFindCompiledLocal(varNameStr, varNameLen, 1, envPtr);
2316     Tcl_DecrRefCount(varNameObj);
2317     if (localVar == -1) {
2318         if (assemEnvPtr->flags & TCL_EVAL_DIRECT) {
2319             Tcl_SetObjResult(interp, Tcl_NewStringObj(
2320                     "cannot use this instruction to create a variable"
2321                     " in a non-proc context", -1));
2322             Tcl_SetErrorCode(interp, "TCL", "ASSEM", "LVT", NULL);
2323         }
2324         return -1;
2325     }
2326     *tokenPtrPtr = TokenAfter(tokenPtr);
2327     return localVar;
2328 }
2329 \f
2330 /*
2331  *-----------------------------------------------------------------------------
2332  *
2333  * CheckNamespaceQualifiers --
2334  *
2335  *      Verify that a variable name has no namespace qualifiers before
2336  *      attempting to install it in the LVT.
2337  *
2338  * Results:
2339  *      On success, returns TCL_OK. On failure, returns TCL_ERROR and stores
2340  *      an error message in the interpreter result.
2341  *
2342  *-----------------------------------------------------------------------------
2343  */
2344
2345 static int
2346 CheckNamespaceQualifiers(
2347     Tcl_Interp* interp,         /* Tcl interpreter for error reporting */
2348     const char* name,           /* Variable name to check */
2349     int nameLen)                /* Length of the variable */
2350 {
2351     const char* p;
2352
2353     for (p = name; p+2 < name+nameLen;  p++) {
2354         if ((*p == ':') && (p[1] == ':')) {
2355             Tcl_SetObjResult(interp, Tcl_ObjPrintf(
2356                     "variable \"%s\" is not local", name));
2357             Tcl_SetErrorCode(interp, "TCL", "ASSEM", "NONLOCAL", name, NULL);
2358             return TCL_ERROR;
2359         }
2360     }
2361     return TCL_OK;
2362 }
2363 \f
2364 /*
2365  *-----------------------------------------------------------------------------
2366  *
2367  * CheckOneByte --
2368  *
2369  *      Verify that a constant fits in a single byte in the instruction
2370  *      stream.
2371  *
2372  * Results:
2373  *      On success, returns TCL_OK. On failure, returns TCL_ERROR and stores
2374  *      an error message in the interpreter result.
2375  *
2376  * This code is here primarily to verify that instructions like INCR_SCALAR1
2377  * are possible on a given local variable. The fact that there is no
2378  * INCR_SCALAR4 is puzzling.
2379  *
2380  *-----------------------------------------------------------------------------
2381  */
2382
2383 static int
2384 CheckOneByte(
2385     Tcl_Interp* interp,         /* Tcl interpreter for error reporting */
2386     int value)                  /* Value to check */
2387 {
2388     Tcl_Obj* result;            /* Error message */
2389
2390     if (value < 0 || value > 0xFF) {
2391         result = Tcl_NewStringObj("operand does not fit in one byte", -1);
2392         Tcl_SetObjResult(interp, result);
2393         Tcl_SetErrorCode(interp, "TCL", "ASSEM", "1BYTE", NULL);
2394         return TCL_ERROR;
2395     }
2396     return TCL_OK;
2397 }
2398 \f
2399 /*
2400  *-----------------------------------------------------------------------------
2401  *
2402  * CheckSignedOneByte --
2403  *
2404  *      Verify that a constant fits in a single signed byte in the instruction
2405  *      stream.
2406  *
2407  * Results:
2408  *      On success, returns TCL_OK. On failure, returns TCL_ERROR and stores
2409  *      an error message in the interpreter result.
2410  *
2411  * This code is here primarily to verify that instructions like INCR_SCALAR1
2412  * are possible on a given local variable. The fact that there is no
2413  * INCR_SCALAR4 is puzzling.
2414  *
2415  *-----------------------------------------------------------------------------
2416  */
2417
2418 static int
2419 CheckSignedOneByte(
2420     Tcl_Interp* interp,         /* Tcl interpreter for error reporting */
2421     int value)                  /* Value to check */
2422 {
2423     Tcl_Obj* result;            /* Error message */
2424
2425     if (value > 0x7F || value < -0x80) {
2426         result = Tcl_NewStringObj("operand does not fit in one byte", -1);
2427         Tcl_SetObjResult(interp, result);
2428         Tcl_SetErrorCode(interp, "TCL", "ASSEM", "1BYTE", NULL);
2429         return TCL_ERROR;
2430     }
2431     return TCL_OK;
2432 }
2433 \f
2434 /*
2435  *-----------------------------------------------------------------------------
2436  *
2437  * CheckNonNegative --
2438  *
2439  *      Verify that a constant is nonnegative
2440  *
2441  * Results:
2442  *      On success, returns TCL_OK. On failure, returns TCL_ERROR and stores
2443  *      an error message in the interpreter result.
2444  *
2445  * This code is here primarily to verify that instructions like INCR_INVOKE
2446  * are consuming a positive number of operands
2447  *
2448  *-----------------------------------------------------------------------------
2449  */
2450
2451 static int
2452 CheckNonNegative(
2453     Tcl_Interp* interp,         /* Tcl interpreter for error reporting */
2454     int value)                  /* Value to check */
2455 {
2456     Tcl_Obj* result;            /* Error message */
2457
2458     if (value < 0) {
2459         result = Tcl_NewStringObj("operand must be nonnegative", -1);
2460         Tcl_SetObjResult(interp, result);
2461         Tcl_SetErrorCode(interp, "TCL", "ASSEM", "NONNEGATIVE", NULL);
2462         return TCL_ERROR;
2463     }
2464     return TCL_OK;
2465 }
2466 \f
2467 /*
2468  *-----------------------------------------------------------------------------
2469  *
2470  * CheckStrictlyPositive --
2471  *
2472  *      Verify that a constant is positive
2473  *
2474  * Results:
2475  *      On success, returns TCL_OK. On failure, returns TCL_ERROR and
2476  *      stores an error message in the interpreter result.
2477  *
2478  * This code is here primarily to verify that instructions like INCR_INVOKE
2479  * are consuming a positive number of operands
2480  *
2481  *-----------------------------------------------------------------------------
2482  */
2483
2484 static int
2485 CheckStrictlyPositive(
2486     Tcl_Interp* interp,         /* Tcl interpreter for error reporting */
2487     int value)                  /* Value to check */
2488 {
2489     Tcl_Obj* result;            /* Error message */
2490
2491     if (value <= 0) {
2492         result = Tcl_NewStringObj("operand must be positive", -1);
2493         Tcl_SetObjResult(interp, result);
2494         Tcl_SetErrorCode(interp, "TCL", "ASSEM", "POSITIVE", NULL);
2495         return TCL_ERROR;
2496     }
2497     return TCL_OK;
2498 }
2499 \f
2500 /*
2501  *-----------------------------------------------------------------------------
2502  *
2503  * DefineLabel --
2504  *
2505  *      Defines a label appearing in the assembly sequence.
2506  *
2507  * Results:
2508  *      Returns a standard Tcl result. Returns TCL_OK and an empty result if
2509  *      the definition succeeds; returns TCL_ERROR and an appropriate message
2510  *      if a duplicate definition is found.
2511  *
2512  *-----------------------------------------------------------------------------
2513  */
2514
2515 static int
2516 DefineLabel(
2517     AssemblyEnv* assemEnvPtr,   /* Assembly environment */
2518     const char* labelName)      /* Label being defined */
2519 {
2520     CompileEnv* envPtr = assemEnvPtr->envPtr;
2521                                 /* Compilation environment */
2522     Tcl_Interp* interp = (Tcl_Interp*) envPtr->iPtr;
2523                                 /* Tcl interpreter */
2524     Tcl_HashEntry* entry;       /* Label's entry in the symbol table */
2525     int isNew;                  /* Flag == 1 iff the label was previously
2526                                  * undefined */
2527
2528     /* TODO - This can now be simplified! */
2529
2530     StartBasicBlock(assemEnvPtr, BB_FALLTHRU, NULL);
2531
2532     /*
2533      * Look up the newly-defined label in the symbol table.
2534      */
2535
2536     entry = Tcl_CreateHashEntry(&assemEnvPtr->labelHash, labelName, &isNew);
2537     if (!isNew) {
2538         /*
2539          * This is a duplicate label.
2540          */
2541
2542         if (assemEnvPtr->flags & TCL_EVAL_DIRECT) {
2543             Tcl_SetObjResult(interp, Tcl_ObjPrintf(
2544                     "duplicate definition of label \"%s\"", labelName));
2545             Tcl_SetErrorCode(interp, "TCL", "ASSEM", "DUPLABEL", labelName,
2546                     NULL);
2547         }
2548         return TCL_ERROR;
2549     }
2550
2551     /*
2552      * This is the first appearance of the label in the code.
2553      */
2554
2555     Tcl_SetHashValue(entry, assemEnvPtr->curr_bb);
2556     return TCL_OK;
2557 }
2558 \f
2559 /*
2560  *-----------------------------------------------------------------------------
2561  *
2562  * StartBasicBlock --
2563  *
2564  *      Starts a new basic block when a label or jump is encountered.
2565  *
2566  * Results:
2567  *      Returns a pointer to the BasicBlock structure of the new
2568  *      basic block.
2569  *
2570  *-----------------------------------------------------------------------------
2571  */
2572
2573 static BasicBlock*
2574 StartBasicBlock(
2575     AssemblyEnv* assemEnvPtr,   /* Assembly environment */
2576     int flags,                  /* Flags to apply to the basic block being
2577                                  * closed, if there is one. */
2578     Tcl_Obj* jumpLabel)         /* Label of the location that the block jumps
2579                                  * to, or NULL if the block does not jump */
2580 {
2581     CompileEnv* envPtr = assemEnvPtr->envPtr;
2582                                 /* Compilation environment */
2583     BasicBlock* newBB;          /* BasicBlock structure for the new block */
2584     BasicBlock* currBB = assemEnvPtr->curr_bb;
2585
2586     /*
2587      * Coalesce zero-length blocks.
2588      */
2589
2590     if (currBB->startOffset == envPtr->codeNext - envPtr->codeStart) {
2591         currBB->startLine = assemEnvPtr->cmdLine;
2592         return currBB;
2593     }
2594
2595     /*
2596      * Make the new basic block.
2597      */
2598
2599     newBB = AllocBB(assemEnvPtr);
2600
2601     /*
2602      * Record the jump target if there is one.
2603      */
2604
2605     currBB->jumpTarget = jumpLabel;
2606     if (jumpLabel != NULL) {
2607         Tcl_IncrRefCount(currBB->jumpTarget);
2608     }
2609
2610     /*
2611      * Record the fallthrough if there is one.
2612      */
2613
2614     currBB->flags |= flags;
2615
2616     /*
2617      * Record the successor block.
2618      */
2619
2620     currBB->successor1 = newBB;
2621     assemEnvPtr->curr_bb = newBB;
2622     return newBB;
2623 }
2624 \f
2625 /*
2626  *-----------------------------------------------------------------------------
2627  *
2628  * AllocBB --
2629  *
2630  *      Allocates a new basic block
2631  *
2632  * Results:
2633  *      Returns a pointer to the newly allocated block, which is initialized
2634  *      to contain no code and begin at the current instruction pointer.
2635  *
2636  *-----------------------------------------------------------------------------
2637  */
2638
2639 static BasicBlock *
2640 AllocBB(
2641     AssemblyEnv* assemEnvPtr)   /* Assembly environment */
2642 {
2643     CompileEnv* envPtr = assemEnvPtr->envPtr;
2644     BasicBlock *bb = (BasicBlock*)ckalloc(sizeof(BasicBlock));
2645
2646     bb->originalStartOffset =
2647             bb->startOffset = envPtr->codeNext - envPtr->codeStart;
2648     bb->startLine = assemEnvPtr->cmdLine + 1;
2649     bb->jumpOffset = -1;
2650     bb->jumpLine = -1;
2651     bb->prevPtr = assemEnvPtr->curr_bb;
2652     bb->predecessor = NULL;
2653     bb->successor1 = NULL;
2654     bb->jumpTarget = NULL;
2655     bb->initialStackDepth = 0;
2656     bb->minStackDepth = 0;
2657     bb->maxStackDepth = 0;
2658     bb->finalStackDepth = 0;
2659     bb->catchDepth = 0;
2660     bb->enclosingCatch = NULL;
2661     bb->foreignExceptionBase = -1;
2662     bb->foreignExceptionCount = 0;
2663     bb->foreignExceptions = NULL;
2664     bb->jtPtr = NULL;
2665     bb->flags = 0;
2666
2667     return bb;
2668 }
2669 \f
2670 /*
2671  *-----------------------------------------------------------------------------
2672  *
2673  * FinishAssembly --
2674  *
2675  *      Postprocessing after all bytecode has been generated for a block of
2676  *      assembly code.
2677  *
2678  * Results:
2679  *      Returns a standard Tcl result, with an error message left in the
2680  *      interpreter if appropriate.
2681  *
2682  * Side effects:
2683  *      The program is checked to see if any undefined labels remain.  The
2684  *      initial stack depth of all the basic blocks in the flow graph is
2685  *      calculated and saved.  The stack balance on exit is computed, checked
2686  *      and saved.
2687  *
2688  *-----------------------------------------------------------------------------
2689  */
2690
2691 static int
2692 FinishAssembly(
2693     AssemblyEnv* assemEnvPtr)   /* Assembly environment */
2694 {
2695     int mustMove;               /* Amount by which the code needs to be grown
2696                                  * because of expanding jumps */
2697
2698     /*
2699      * Resolve the targets of all jumps and determine whether code needs to be
2700      * moved around.
2701      */
2702
2703     if (CalculateJumpRelocations(assemEnvPtr, &mustMove)) {
2704         return TCL_ERROR;
2705     }
2706
2707     /*
2708      * Move the code if necessary.
2709      */
2710
2711     if (mustMove) {
2712         MoveCodeForJumps(assemEnvPtr, mustMove);
2713     }
2714
2715     /*
2716      * Resolve jump target labels to bytecode offsets.
2717      */
2718
2719     FillInJumpOffsets(assemEnvPtr);
2720
2721     /*
2722      * Label each basic block with its catch context. Quit on inconsistency.
2723      */
2724
2725     if (ProcessCatches(assemEnvPtr) != TCL_OK) {
2726         return TCL_ERROR;
2727     }
2728
2729     /*
2730      * Make sure that no block accessible from a catch's error exit that hasn't
2731      * popped the exception stack can throw an exception.
2732      */
2733
2734     if (CheckForThrowInWrongContext(assemEnvPtr) != TCL_OK) {
2735         return TCL_ERROR;
2736     }
2737
2738     /*
2739      * Compute stack balance throughout the program.
2740      */
2741
2742     if (CheckStack(assemEnvPtr) != TCL_OK) {
2743         return TCL_ERROR;
2744     }
2745
2746     /*
2747      * TODO - Check for unreachable code. Or maybe not; unreachable code is
2748      * Mostly Harmless.
2749      */
2750
2751     return TCL_OK;
2752 }
2753 \f
2754 /*
2755  *-----------------------------------------------------------------------------
2756  *
2757  * CalculateJumpRelocations --
2758  *
2759  *      Calculate any movement that has to be done in the assembly code to
2760  *      expand JUMP1 instructions to JUMP4 (because they jump more than a
2761  *      1-byte range).
2762  *
2763  * Results:
2764  *      Returns a standard Tcl result, with an appropriate error message if
2765  *      anything fails.
2766  *
2767  * Side effects:
2768  *      Sets the 'startOffset' pointer in every basic block to the new origin
2769  *      of the block, and turns off JUMP1 flags on instructions that must be
2770  *      expanded (and adjusts them to the corresponding JUMP4's).  Does *not*
2771  *      store the jump offsets at this point.
2772  *
2773  *      Sets *mustMove to 1 if and only if at least one instruction changed
2774  *      size so the code must be moved.
2775  *
2776  *      As a side effect, also checks for undefined labels and reports them.
2777  *
2778  *-----------------------------------------------------------------------------
2779  */
2780
2781 static int
2782 CalculateJumpRelocations(
2783     AssemblyEnv* assemEnvPtr,   /* Assembly environment */
2784     int* mustMove)              /* OUTPUT: Number of bytes that have been
2785                                  * added to the code */
2786 {
2787     CompileEnv* envPtr = assemEnvPtr->envPtr;
2788                                 /* Compilation environment */
2789     BasicBlock* bbPtr;          /* Pointer to a basic block being checked */
2790     Tcl_HashEntry* entry;       /* Exit label's entry in the symbol table */
2791     BasicBlock* jumpTarget;     /* Basic block where the jump goes */
2792     int motion;                 /* Amount by which the code has expanded */
2793     int offset;                 /* Offset in the bytecode from a jump
2794                                  * instruction to its target */
2795     unsigned opcode;            /* Opcode in the bytecode being adjusted */
2796
2797     /*
2798      * Iterate through basic blocks as long as a change results in code
2799      * expansion.
2800      */
2801
2802     *mustMove = 0;
2803     do {
2804         motion = 0;
2805         for (bbPtr = assemEnvPtr->head_bb;
2806                 bbPtr != NULL;
2807                 bbPtr = bbPtr->successor1) {
2808             /*
2809              * Advance the basic block start offset by however many bytes we
2810              * have inserted in the code up to this point
2811              */
2812
2813             bbPtr->startOffset += motion;
2814
2815             /*
2816              * If the basic block references a label (and hence performs a
2817              * jump), find the location of the label. Report an error if the
2818              * label is missing.
2819              */
2820
2821             if (bbPtr->jumpTarget != NULL) {
2822                 entry = Tcl_FindHashEntry(&assemEnvPtr->labelHash,
2823                         Tcl_GetString(bbPtr->jumpTarget));
2824                 if (entry == NULL) {
2825                     ReportUndefinedLabel(assemEnvPtr, bbPtr,
2826                             bbPtr->jumpTarget);
2827                     return TCL_ERROR;
2828                 }
2829
2830                 /*
2831                  * If the instruction is a JUMP1, turn it into a JUMP4 if its
2832                  * target is out of range.
2833                  */
2834
2835                 jumpTarget = (BasicBlock*)Tcl_GetHashValue(entry);
2836                 if (bbPtr->flags & BB_JUMP1) {
2837                     offset = jumpTarget->startOffset
2838                             - (bbPtr->jumpOffset + motion);
2839                     if (offset < -0x80 || offset > 0x7F) {
2840                         opcode = TclGetUInt1AtPtr(envPtr->codeStart
2841                                 + bbPtr->jumpOffset);
2842                         ++opcode;
2843                         TclStoreInt1AtPtr(opcode,
2844                                 envPtr->codeStart + bbPtr->jumpOffset);
2845                         motion += 3;
2846                         bbPtr->flags &= ~BB_JUMP1;
2847                     }
2848                 }
2849             }
2850
2851             /*
2852              * If the basic block references a jump table, that doesn't affect
2853              * the code locations, but resolve the labels now, and store basic
2854              * block pointers in the jumptable hash.
2855              */
2856
2857             if (bbPtr->flags & BB_JUMPTABLE) {
2858                 if (CheckJumpTableLabels(assemEnvPtr, bbPtr) != TCL_OK) {
2859                     return TCL_ERROR;
2860                 }
2861             }
2862         }
2863         *mustMove += motion;
2864     } while (motion != 0);
2865
2866     return TCL_OK;
2867 }
2868 \f
2869 /*
2870  *-----------------------------------------------------------------------------
2871  *
2872  * CheckJumpTableLabels --
2873  *
2874  *      Make sure that all the labels in a jump table are defined.
2875  *
2876  * Results:
2877  *      Returns TCL_OK if they are, TCL_ERROR if they aren't.
2878  *
2879  *-----------------------------------------------------------------------------
2880  */
2881
2882 static int
2883 CheckJumpTableLabels(
2884     AssemblyEnv* assemEnvPtr,   /* Assembly environment */
2885     BasicBlock* bbPtr)          /* Basic block that ends in a jump table */
2886 {
2887     Tcl_HashTable* symHash = &bbPtr->jtPtr->hashTable;
2888                                 /* Hash table with the symbols */
2889     Tcl_HashSearch search;      /* Hash table iterator */
2890     Tcl_HashEntry* symEntryPtr; /* Hash entry for the symbols */
2891     Tcl_Obj* symbolObj;         /* Jump target */
2892     Tcl_HashEntry* valEntryPtr; /* Hash entry for the resolutions */
2893
2894     /*
2895      * Look up every jump target in the jump hash.
2896      */
2897
2898     DEBUG_PRINT("check jump table labels %p {\n", bbPtr);
2899     for (symEntryPtr = Tcl_FirstHashEntry(symHash, &search);
2900             symEntryPtr != NULL;
2901             symEntryPtr = Tcl_NextHashEntry(&search)) {
2902         symbolObj = (Tcl_Obj*)Tcl_GetHashValue(symEntryPtr);
2903         valEntryPtr = Tcl_FindHashEntry(&assemEnvPtr->labelHash,
2904                 Tcl_GetString(symbolObj));
2905         DEBUG_PRINT("  %s -> %s (%d)\n",
2906                 (char*) Tcl_GetHashKey(symHash, symEntryPtr),
2907                 Tcl_GetString(symbolObj), (valEntryPtr != NULL));
2908         if (valEntryPtr == NULL) {
2909             ReportUndefinedLabel(assemEnvPtr, bbPtr, symbolObj);
2910             return TCL_ERROR;
2911         }
2912     }
2913     DEBUG_PRINT("}\n");
2914     return TCL_OK;
2915 }
2916 \f
2917 /*
2918  *-----------------------------------------------------------------------------
2919  *
2920  * ReportUndefinedLabel --
2921  *
2922  *      Report that a basic block refers to an undefined jump label
2923  *
2924  * Side effects:
2925  *      Stores an error message, error code, and line number information in
2926  *      the assembler's Tcl interpreter.
2927  *
2928  *-----------------------------------------------------------------------------
2929  */
2930
2931 static void
2932 ReportUndefinedLabel(
2933     AssemblyEnv* assemEnvPtr,   /* Assembly environment */
2934     BasicBlock* bbPtr,          /* Basic block that contains the undefined
2935                                  * label */
2936     Tcl_Obj* jumpTarget)        /* Label of a jump target */
2937 {
2938     CompileEnv* envPtr = assemEnvPtr->envPtr;
2939                                 /* Compilation environment */
2940     Tcl_Interp* interp = (Tcl_Interp*) envPtr->iPtr;
2941                                 /* Tcl interpreter */
2942
2943     if (assemEnvPtr->flags & TCL_EVAL_DIRECT) {
2944         Tcl_SetObjResult(interp, Tcl_ObjPrintf(
2945                 "undefined label \"%s\"", Tcl_GetString(jumpTarget)));
2946         Tcl_SetErrorCode(interp, "TCL", "ASSEM", "NOLABEL",
2947                 Tcl_GetString(jumpTarget), NULL);
2948         Tcl_SetErrorLine(interp, bbPtr->jumpLine);
2949     }
2950 }
2951 \f
2952 /*
2953  *-----------------------------------------------------------------------------
2954  *
2955  * MoveCodeForJumps --
2956  *
2957  *      Move bytecodes in memory to accommodate JUMP1 instructions that have
2958  *      expanded to become JUMP4's.
2959  *
2960  *-----------------------------------------------------------------------------
2961  */
2962
2963 static void
2964 MoveCodeForJumps(
2965     AssemblyEnv* assemEnvPtr,   /* Assembler environment */
2966     int mustMove)               /* Number of bytes of added code */
2967 {
2968     CompileEnv* envPtr = assemEnvPtr->envPtr;
2969                                 /* Compilation environment */
2970     BasicBlock* bbPtr;          /* Pointer to a basic block being checked */
2971     int topOffset;              /* Bytecode offset of the following basic
2972                                  * block before code motion */
2973
2974     /*
2975      * Make sure that there is enough space in the bytecode array to
2976      * accommodate the expanded code.
2977      */
2978
2979     while (envPtr->codeEnd < envPtr->codeNext + mustMove) {
2980         TclExpandCodeArray(envPtr);
2981     }
2982
2983     /*
2984      * Iterate through the bytecodes in reverse order, and move them upward to
2985      * their new homes.
2986      */
2987
2988     topOffset = envPtr->codeNext - envPtr->codeStart;
2989     for (bbPtr = assemEnvPtr->curr_bb; bbPtr != NULL; bbPtr = bbPtr->prevPtr) {
2990         DEBUG_PRINT("move code from %d to %d\n",
2991                 bbPtr->originalStartOffset, bbPtr->startOffset);
2992         memmove(envPtr->codeStart + bbPtr->startOffset,
2993                 envPtr->codeStart + bbPtr->originalStartOffset,
2994                 topOffset - bbPtr->originalStartOffset);
2995         topOffset = bbPtr->originalStartOffset;
2996         bbPtr->jumpOffset += (bbPtr->startOffset - bbPtr->originalStartOffset);
2997     }
2998     envPtr->codeNext += mustMove;
2999 }
3000 \f
3001 /*
3002  *-----------------------------------------------------------------------------
3003  *
3004  * FillInJumpOffsets --
3005  *
3006  *      Fill in the final offsets of all jump instructions once bytecode
3007  *      locations have been completely determined.
3008  *
3009  *-----------------------------------------------------------------------------
3010  */
3011
3012 static void
3013 FillInJumpOffsets(
3014     AssemblyEnv* assemEnvPtr)   /* Assembly environment */
3015 {
3016     CompileEnv* envPtr = assemEnvPtr->envPtr;
3017                                 /* Compilation environment */
3018     BasicBlock* bbPtr;          /* Pointer to a basic block being checked */
3019     Tcl_HashEntry* entry;       /* Hashtable entry for a jump target label */
3020     BasicBlock* jumpTarget;     /* Basic block where a jump goes */
3021     int fromOffset;             /* Bytecode location of a jump instruction */
3022     int targetOffset;           /* Bytecode location of a jump instruction's
3023                                  * target */
3024
3025     for (bbPtr = assemEnvPtr->head_bb;
3026             bbPtr != NULL;
3027             bbPtr = bbPtr->successor1) {
3028         if (bbPtr->jumpTarget != NULL) {
3029             entry = Tcl_FindHashEntry(&assemEnvPtr->labelHash,
3030                     Tcl_GetString(bbPtr->jumpTarget));
3031             jumpTarget = (BasicBlock*)Tcl_GetHashValue(entry);
3032             fromOffset = bbPtr->jumpOffset;
3033             targetOffset = jumpTarget->startOffset;
3034             if (bbPtr->flags & BB_JUMP1) {
3035                 TclStoreInt1AtPtr(targetOffset - fromOffset,
3036                         envPtr->codeStart + fromOffset + 1);
3037             } else {
3038                 TclStoreInt4AtPtr(targetOffset - fromOffset,
3039                         envPtr->codeStart + fromOffset + 1);
3040             }
3041         }
3042         if (bbPtr->flags & BB_JUMPTABLE) {
3043             ResolveJumpTableTargets(assemEnvPtr, bbPtr);
3044         }
3045     }
3046 }
3047 \f
3048 /*
3049  *-----------------------------------------------------------------------------
3050  *
3051  * ResolveJumpTableTargets --
3052  *
3053  *      Puts bytecode addresses for the targets of a jumptable into the
3054  *      table
3055  *
3056  * Results:
3057  *      Returns TCL_OK if they are, TCL_ERROR if they aren't.
3058  *
3059  *-----------------------------------------------------------------------------
3060  */
3061
3062 static void
3063 ResolveJumpTableTargets(
3064     AssemblyEnv* assemEnvPtr,   /* Assembly environment */
3065     BasicBlock* bbPtr)          /* Basic block that ends in a jump table */
3066 {
3067     CompileEnv* envPtr = assemEnvPtr->envPtr;
3068                                 /* Compilation environment */
3069     Tcl_HashTable* symHash = &bbPtr->jtPtr->hashTable;
3070                                 /* Hash table with the symbols */
3071     Tcl_HashSearch search;      /* Hash table iterator */
3072     Tcl_HashEntry* symEntryPtr; /* Hash entry for the symbols */
3073     Tcl_Obj* symbolObj;         /* Jump target */
3074     Tcl_HashEntry* valEntryPtr; /* Hash entry for the resolutions */
3075     int auxDataIndex;           /* Index of the auxdata */
3076     JumptableInfo* realJumpTablePtr;
3077                                 /* Jump table in the actual code */
3078     Tcl_HashTable* realJumpHashPtr;
3079                                 /* Jump table hash in the actual code */
3080     Tcl_HashEntry* realJumpEntryPtr;
3081                                 /* Entry in the jump table hash in
3082                                  * the actual code */
3083     BasicBlock* jumpTargetBBPtr;
3084                                 /* Basic block that the jump proceeds to */
3085     int junk;
3086
3087     auxDataIndex = TclGetInt4AtPtr(envPtr->codeStart + bbPtr->jumpOffset + 1);
3088     DEBUG_PRINT("bbPtr = %p jumpOffset = %d auxDataIndex = %d\n",
3089             bbPtr, bbPtr->jumpOffset, auxDataIndex);
3090     realJumpTablePtr = (JumptableInfo*)TclFetchAuxData(envPtr, auxDataIndex);
3091     realJumpHashPtr = &realJumpTablePtr->hashTable;
3092
3093     /*
3094      * Look up every jump target in the jump hash.
3095      */
3096
3097     DEBUG_PRINT("resolve jump table {\n");
3098     for (symEntryPtr = Tcl_FirstHashEntry(symHash, &search);
3099             symEntryPtr != NULL;
3100             symEntryPtr = Tcl_NextHashEntry(&search)) {
3101         symbolObj = (Tcl_Obj*)Tcl_GetHashValue(symEntryPtr);
3102         DEBUG_PRINT("     symbol %s\n", Tcl_GetString(symbolObj));
3103
3104         valEntryPtr = Tcl_FindHashEntry(&assemEnvPtr->labelHash,
3105                 Tcl_GetString(symbolObj));
3106         jumpTargetBBPtr = (BasicBlock*)Tcl_GetHashValue(valEntryPtr);
3107
3108         realJumpEntryPtr = Tcl_CreateHashEntry(realJumpHashPtr,
3109                 Tcl_GetHashKey(symHash, symEntryPtr), &junk);
3110         DEBUG_PRINT("  %s -> %s -> bb %p (pc %d)    hash entry %p\n",
3111                 (char*) Tcl_GetHashKey(symHash, symEntryPtr),
3112                 Tcl_GetString(symbolObj), jumpTargetBBPtr,
3113                 jumpTargetBBPtr->startOffset, realJumpEntryPtr);
3114
3115         Tcl_SetHashValue(realJumpEntryPtr,
3116                 INT2PTR(jumpTargetBBPtr->startOffset - bbPtr->jumpOffset));
3117     }
3118     DEBUG_PRINT("}\n");
3119 }
3120 \f
3121 /*
3122  *-----------------------------------------------------------------------------
3123  *
3124  * CheckForThrowInWrongContext --
3125  *
3126  *      Verify that no beginCatch/endCatch sequence can throw an exception
3127  *      after an original exception is caught and before its exception context
3128  *      is removed from the stack.
3129  *
3130  * Results:
3131  *      Returns a standard Tcl result.
3132  *
3133  * Side effects:
3134  *      Stores an appropriate error message in the interpreter as needed.
3135  *
3136  *-----------------------------------------------------------------------------
3137  */
3138
3139 static int
3140 CheckForThrowInWrongContext(
3141     AssemblyEnv* assemEnvPtr)   /* Assembly environment */
3142 {
3143     BasicBlock* blockPtr;       /* Current basic block */
3144
3145     /*
3146      * Walk through the basic blocks in turn, checking all the ones that have
3147      * caught an exception and not disposed of it properly.
3148      */
3149
3150     for (blockPtr = assemEnvPtr->head_bb;
3151             blockPtr != NULL;
3152             blockPtr = blockPtr->successor1) {
3153         if (blockPtr->catchState == BBCS_CAUGHT) {
3154             /*
3155              * Walk through the instructions in the basic block.
3156              */
3157
3158             if (CheckNonThrowingBlock(assemEnvPtr, blockPtr) != TCL_OK) {
3159                 return TCL_ERROR;
3160             }
3161         }
3162     }
3163     return TCL_OK;
3164 }
3165 \f
3166 /*
3167  *-----------------------------------------------------------------------------
3168  *
3169  * CheckNonThrowingBlock --
3170  *
3171  *      Check that a basic block cannot throw an exception.
3172  *
3173  * Results:
3174  *      Returns TCL_ERROR if the block cannot be proven to be nonthrowing.
3175  *
3176  * Side effects:
3177  *      Stashes an error message in the interpreter result.
3178  *
3179  *-----------------------------------------------------------------------------
3180  */
3181
3182 static int
3183 CheckNonThrowingBlock(
3184     AssemblyEnv* assemEnvPtr,   /* Assembly environment */
3185     BasicBlock* blockPtr)       /* Basic block where exceptions are not
3186                                  * allowed */
3187 {
3188     CompileEnv* envPtr = assemEnvPtr->envPtr;
3189                                 /* Compilation environment */
3190     Tcl_Interp* interp = (Tcl_Interp*) envPtr->iPtr;
3191                                 /* Tcl interpreter */
3192     BasicBlock* nextPtr;        /* Pointer to the succeeding basic block */
3193     int offset;                 /* Bytecode offset of the current
3194                                  * instruction */
3195     int bound;                  /* Bytecode offset following the last
3196                                  * instruction of the block. */
3197     unsigned char opcode;       /* Current bytecode instruction */
3198
3199     /*
3200      * Determine where in the code array the basic block ends.
3201      */
3202
3203     nextPtr = blockPtr->successor1;
3204     if (nextPtr == NULL) {
3205         bound = envPtr->codeNext - envPtr->codeStart;
3206     } else {
3207         bound = nextPtr->startOffset;
3208     }
3209
3210     /*
3211      * Walk through the instructions of the block.
3212      */
3213
3214     offset = blockPtr->startOffset;
3215     while (offset < bound) {
3216         /*
3217          * Determine whether an instruction is nonthrowing.
3218          */
3219
3220         opcode = (envPtr->codeStart)[offset];
3221         if (BytecodeMightThrow(opcode)) {
3222             /*
3223              * Report an error for a throw in the wrong context.
3224              */
3225
3226             if (assemEnvPtr->flags & TCL_EVAL_DIRECT) {
3227                 Tcl_SetObjResult(interp, Tcl_ObjPrintf(
3228                         "\"%s\" instruction may not appear in "
3229                         "a context where an exception has been "
3230                         "caught and not disposed of.",
3231                         tclInstructionTable[opcode].name));
3232                 Tcl_SetErrorCode(interp, "TCL", "ASSEM", "BADTHROW", NULL);
3233                 AddBasicBlockRangeToErrorInfo(assemEnvPtr, blockPtr);
3234             }
3235             return TCL_ERROR;
3236         }
3237         offset += tclInstructionTable[opcode].numBytes;
3238     }
3239     return TCL_OK;
3240 }
3241 \f
3242 /*
3243  *-----------------------------------------------------------------------------
3244  *
3245  * BytecodeMightThrow --
3246  *
3247  *      Tests if a given bytecode instruction might throw an exception.
3248  *
3249  * Results:
3250  *      Returns 1 if the bytecode might throw an exception, 0 if the
3251  *      instruction is known never to throw.
3252  *
3253  *-----------------------------------------------------------------------------
3254  */
3255
3256 static int
3257 BytecodeMightThrow(
3258     unsigned char opcode)
3259 {
3260     /*
3261      * Binary search on the non-throwing bytecode list.
3262      */
3263
3264     int min = 0;
3265     int max = sizeof(NonThrowingByteCodes) - 1;
3266     int mid;
3267     unsigned char c;
3268
3269     while (max >= min) {
3270         mid = (min + max) / 2;
3271         c = NonThrowingByteCodes[mid];
3272         if (opcode < c) {
3273             max = mid-1;
3274         } else if (opcode > c) {
3275             min = mid+1;
3276         } else {
3277             /*
3278              * Opcode is nonthrowing.
3279              */
3280
3281             return 0;
3282         }
3283     }
3284
3285     return 1;
3286 }
3287 \f
3288 /*
3289  *-----------------------------------------------------------------------------
3290  *
3291  * CheckStack --
3292  *
3293  *      Audit stack usage in a block of assembly code.
3294  *
3295  * Results:
3296  *      Returns a standard Tcl result.
3297  *
3298  * Side effects:
3299  *      Updates stack depth on entry for all basic blocks in the flowgraph.
3300  *      Calculates the max stack depth used in the program, and updates the
3301  *      compilation environment to reflect it.
3302  *
3303  *-----------------------------------------------------------------------------
3304  */
3305
3306 static int
3307 CheckStack(
3308     AssemblyEnv* assemEnvPtr)   /* Assembly environment */
3309 {
3310     CompileEnv* envPtr = assemEnvPtr->envPtr;
3311                                 /* Compilation environment */
3312     int maxDepth;               /* Maximum stack depth overall */
3313
3314     /*
3315      * Checking the head block will check all the other blocks recursively.
3316      */
3317
3318     assemEnvPtr->maxDepth = 0;
3319     if (StackCheckBasicBlock(assemEnvPtr, assemEnvPtr->head_bb, NULL,
3320             0) == TCL_ERROR) {
3321         return TCL_ERROR;
3322     }
3323
3324     /*
3325      * Post the max stack depth back to the compilation environment.
3326      */
3327
3328     maxDepth = assemEnvPtr->maxDepth + envPtr->currStackDepth;
3329     if (maxDepth > envPtr->maxStackDepth) {
3330         envPtr->maxStackDepth = maxDepth;
3331     }
3332
3333     /*
3334      * If the exit is reachable, make sure that the program exits with 1
3335      * operand on the stack.
3336      */
3337
3338     if (StackCheckExit(assemEnvPtr) != TCL_OK) {
3339         return TCL_ERROR;
3340     }
3341
3342     /*
3343      * Reset the visited state on all basic blocks.
3344      */
3345
3346     ResetVisitedBasicBlocks(assemEnvPtr);
3347     return TCL_OK;
3348 }
3349 \f
3350 /*
3351  *-----------------------------------------------------------------------------
3352  *
3353  * StackCheckBasicBlock --
3354  *
3355  *      Checks stack consumption for a basic block (and recursively for its
3356  *      successors).
3357  *
3358  * Results:
3359  *      Returns a standard Tcl result.
3360  *
3361  * Side effects:
3362  *      Updates initial stack depth for the basic block and its successors.
3363  *      (Final and maximum stack depth are relative to initial, and are not
3364  *      touched).
3365  *
3366  * This procedure eventually checks, for the entire flow graph, whether stack
3367  * balance is consistent.  It is an error for a given basic block to be
3368  * reachable along multiple flow paths with different stack depths.
3369  *
3370  *-----------------------------------------------------------------------------
3371  */
3372
3373 static int
3374 StackCheckBasicBlock(
3375     AssemblyEnv* assemEnvPtr,   /* Assembly environment */
3376     BasicBlock* blockPtr,       /* Pointer to the basic block being checked */
3377     BasicBlock* predecessor,    /* Pointer to the block that passed control to
3378                                  * this one. */
3379     int initialStackDepth)      /* Stack depth on entry to the block */
3380 {
3381     CompileEnv* envPtr = assemEnvPtr->envPtr;
3382                                 /* Compilation environment */
3383     Tcl_Interp* interp = (Tcl_Interp*) envPtr->iPtr;
3384                                 /* Tcl interpreter */
3385     BasicBlock* jumpTarget;     /* Basic block where a jump goes */
3386     int stackDepth;             /* Current stack depth */
3387     int maxDepth;               /* Maximum stack depth so far */
3388     int result;                 /* Tcl status return */
3389     Tcl_HashSearch jtSearch;    /* Search structure for the jump table */
3390     Tcl_HashEntry* jtEntry;     /* Hash entry in the jump table */
3391     Tcl_Obj* targetLabel;       /* Target label from the jump table */
3392     Tcl_HashEntry* entry;       /* Hash entry in the label table */
3393
3394     if (blockPtr->flags & BB_VISITED) {
3395         /*
3396          * If the block is already visited, check stack depth for consistency
3397          * among the paths that reach it.
3398          */
3399
3400         if (blockPtr->initialStackDepth == initialStackDepth) {
3401             return TCL_OK;
3402         }
3403         if (assemEnvPtr->flags & TCL_EVAL_DIRECT) {
3404             Tcl_SetObjResult(interp, Tcl_NewStringObj(
3405                     "inconsistent stack depths on two execution paths", -1));
3406
3407             /*
3408              * TODO - add execution trace of both paths
3409              */
3410
3411             Tcl_SetErrorLine(interp, blockPtr->startLine);
3412             Tcl_SetErrorCode(interp, "TCL", "ASSEM", "BADSTACK", NULL);
3413         }
3414         return TCL_ERROR;
3415     }
3416
3417     /*
3418      * If the block is not already visited, set the 'predecessor' link to
3419      * indicate how control got to it. Set the initial stack depth to the
3420      * current stack depth in the flow of control.
3421      */
3422
3423     blockPtr->flags |= BB_VISITED;
3424     blockPtr->predecessor = predecessor;
3425     blockPtr->initialStackDepth = initialStackDepth;
3426
3427     /*
3428      * Calculate minimum stack depth, and flag an error if the block
3429      * underflows the stack.
3430      */
3431
3432     if (initialStackDepth + blockPtr->minStackDepth < 0) {
3433         if (assemEnvPtr->flags & TCL_EVAL_DIRECT) {
3434             Tcl_SetObjResult(interp, Tcl_NewStringObj("stack underflow", -1));
3435             Tcl_SetErrorCode(interp, "TCL", "ASSEM", "BADSTACK", NULL);
3436             AddBasicBlockRangeToErrorInfo(assemEnvPtr, blockPtr);
3437             Tcl_SetErrorLine(interp, blockPtr->startLine);
3438         }
3439         return TCL_ERROR;
3440     }
3441
3442     /*
3443      * Make sure that the block doesn't try to pop below the stack level of an
3444      * enclosing catch.
3445      */
3446
3447     if (blockPtr->enclosingCatch != 0 &&
3448             initialStackDepth + blockPtr->minStackDepth
3449             < (blockPtr->enclosingCatch->initialStackDepth
3450                 + blockPtr->enclosingCatch->finalStackDepth)) {
3451         if (assemEnvPtr->flags & TCL_EVAL_DIRECT) {
3452             Tcl_SetObjResult(interp, Tcl_NewStringObj(
3453                     "code pops stack below level of enclosing catch", -1));
3454             Tcl_SetErrorCode(interp, "TCL", "ASSEM", "BADSTACKINCATCH", -1);
3455             AddBasicBlockRangeToErrorInfo(assemEnvPtr, blockPtr);
3456             Tcl_SetErrorLine(interp, blockPtr->startLine);
3457         }
3458         return TCL_ERROR;
3459     }
3460
3461     /*
3462      * Update maximum stgack depth.
3463      */
3464
3465     maxDepth = initialStackDepth + blockPtr->maxStackDepth;
3466     if (maxDepth > assemEnvPtr->maxDepth) {
3467         assemEnvPtr->maxDepth = maxDepth;
3468     }
3469
3470     /*
3471      * Calculate stack depth on exit from the block, and invoke this procedure
3472      * recursively to check successor blocks.
3473      */
3474
3475     stackDepth = initialStackDepth + blockPtr->finalStackDepth;
3476     result = TCL_OK;
3477     if (blockPtr->flags & BB_FALLTHRU) {
3478         result = StackCheckBasicBlock(assemEnvPtr, blockPtr->successor1,
3479                 blockPtr, stackDepth);
3480     }
3481
3482     if (result == TCL_OK && blockPtr->jumpTarget != NULL) {
3483         entry = Tcl_FindHashEntry(&assemEnvPtr->labelHash,
3484                 Tcl_GetString(blockPtr->jumpTarget));
3485         jumpTarget = (BasicBlock*)Tcl_GetHashValue(entry);
3486         result = StackCheckBasicBlock(assemEnvPtr, jumpTarget, blockPtr,
3487                 stackDepth);
3488     }
3489
3490     /*
3491      * All blocks referenced in a jump table are successors.
3492      */
3493
3494     if (blockPtr->flags & BB_JUMPTABLE) {
3495         for (jtEntry = Tcl_FirstHashEntry(&blockPtr->jtPtr->hashTable,
3496                     &jtSearch);
3497                 result == TCL_OK && jtEntry != NULL;
3498                 jtEntry = Tcl_NextHashEntry(&jtSearch)) {
3499             targetLabel = (Tcl_Obj*)Tcl_GetHashValue(jtEntry);
3500             entry = Tcl_FindHashEntry(&assemEnvPtr->labelHash,
3501                     Tcl_GetString(targetLabel));
3502             jumpTarget = (BasicBlock*)Tcl_GetHashValue(entry);
3503             result = StackCheckBasicBlock(assemEnvPtr, jumpTarget,
3504                     blockPtr, stackDepth);
3505         }
3506     }
3507
3508     return result;
3509 }
3510 \f
3511 /*
3512  *-----------------------------------------------------------------------------
3513  *
3514  * StackCheckExit --
3515  *
3516  *      Makes sure that the net stack effect of an entire assembly language
3517  *      script is to push 1 result.
3518  *
3519  * Results:
3520  *      Returns a standard Tcl result, with an error message in the
3521  *      interpreter result if the stack is wrong.
3522  *
3523  * Side effects:
3524  *      If the assembly code had a net stack effect of zero, emits code to the
3525  *      concluding block to push a null result. In any case, updates the stack
3526  *      depth in the compile environment to reflect the net effect of the
3527  *      assembly code.
3528  *
3529  *-----------------------------------------------------------------------------
3530  */
3531
3532 static int
3533 StackCheckExit(
3534     AssemblyEnv* assemEnvPtr)   /* Assembly environment */
3535 {
3536     CompileEnv* envPtr = assemEnvPtr->envPtr;
3537                                 /* Compilation environment */
3538     Tcl_Interp* interp = (Tcl_Interp*) envPtr->iPtr;
3539                                 /* Tcl interpreter */
3540     int depth;                  /* Net stack effect */
3541     int litIndex;               /* Index in the literal pool of the empty
3542                                  * string */
3543     BasicBlock* curr_bb = assemEnvPtr->curr_bb;
3544                                 /* Final basic block in the assembly */
3545
3546     /*
3547      * Don't perform these checks if execution doesn't reach the exit (either
3548      * because of an infinite loop or because the only return is from the
3549      * middle.
3550      */
3551
3552     if (curr_bb->flags & BB_VISITED) {
3553         /*
3554          * Exit with no operands; push an empty one.
3555          */
3556
3557         depth = curr_bb->finalStackDepth + curr_bb->initialStackDepth;
3558         if (depth == 0) {
3559             /*
3560              * Emit a 'push' of the empty literal.
3561              */
3562
3563             litIndex = TclRegisterNewLiteral(envPtr, "", 0);
3564
3565             /*
3566              * Assumes that 'push' is at slot 0 in TalInstructionTable.
3567              */
3568
3569             BBEmitInst1or4(assemEnvPtr, 0, litIndex, 0);
3570             ++depth;
3571         }
3572
3573         /*
3574          * Exit with unbalanced stack.
3575          */
3576
3577         if (depth != 1) {
3578             if (assemEnvPtr->flags & TCL_EVAL_DIRECT) {
3579                 Tcl_SetObjResult(interp, Tcl_ObjPrintf(
3580                         "stack is unbalanced on exit from the code (depth=%d)",
3581                         depth));
3582                 Tcl_SetErrorCode(interp, "TCL", "ASSEM", "BADSTACK", NULL);
3583             }
3584             return TCL_ERROR;
3585         }
3586
3587         /*
3588          * Record stack usage.
3589          */
3590
3591         envPtr->currStackDepth += depth;
3592     }
3593
3594     return TCL_OK;
3595 }
3596 \f
3597 /*
3598  *-----------------------------------------------------------------------------
3599  *
3600  * ProcessCatches --
3601  *
3602  *      First pass of 'catch' processing.
3603  *
3604  * Results:
3605  *      Returns a standard Tcl result, with an appropriate error message if
3606  *      the result is TCL_ERROR.
3607  *
3608  * Side effects:
3609  *      Labels all basic blocks with their enclosing catches.
3610  *
3611  *-----------------------------------------------------------------------------
3612  */
3613
3614 static int
3615 ProcessCatches(
3616     AssemblyEnv* assemEnvPtr)   /* Assembly environment */
3617 {
3618     BasicBlock* blockPtr;       /* Pointer to a basic block */
3619
3620     /*
3621      * Clear the catch state of all basic blocks.
3622      */
3623
3624     for (blockPtr = assemEnvPtr->head_bb;
3625             blockPtr != NULL;
3626             blockPtr = blockPtr->successor1) {
3627         blockPtr->catchState = BBCS_UNKNOWN;
3628         blockPtr->enclosingCatch = NULL;
3629     }
3630
3631     /*
3632      * Start the check recursively from the first basic block, which is
3633      * outside any exception context
3634      */
3635
3636     if (ProcessCatchesInBasicBlock(assemEnvPtr, assemEnvPtr->head_bb,
3637             NULL, BBCS_NONE, 0) != TCL_OK) {
3638         return TCL_ERROR;
3639     }
3640
3641     /*
3642      * Check for unclosed catch on exit.
3643      */
3644
3645     if (CheckForUnclosedCatches(assemEnvPtr) != TCL_OK) {
3646         return TCL_ERROR;
3647     }
3648
3649     /*
3650      * Now there's enough information to build the exception ranges.
3651      */
3652
3653     if (BuildExceptionRanges(assemEnvPtr) != TCL_OK) {
3654         return TCL_ERROR;
3655     }
3656
3657     /*
3658      * Finally, restore any exception ranges from embedded scripts.
3659      */
3660
3661     RestoreEmbeddedExceptionRanges(assemEnvPtr);
3662     return TCL_OK;
3663 }
3664 \f
3665 /*
3666  *-----------------------------------------------------------------------------
3667  *
3668  * ProcessCatchesInBasicBlock --
3669  *
3670  *      First-pass catch processing for one basic block.
3671  *
3672  * Results:
3673  *      Returns a standard Tcl result, with error message in the interpreter
3674  *      result if an error occurs.
3675  *
3676  * This procedure checks consistency of the exception context through the
3677  * assembler program, and records the enclosing 'catch' for every basic block.
3678  *
3679  *-----------------------------------------------------------------------------
3680  */
3681
3682 static int
3683 ProcessCatchesInBasicBlock(
3684     AssemblyEnv* assemEnvPtr,   /* Assembly environment */
3685     BasicBlock* bbPtr,          /* Basic block being processed */
3686     BasicBlock* enclosing,      /* Start basic block of the enclosing catch */
3687     enum BasicBlockCatchState state,
3688                                 /* BBCS_NONE, BBCS_INCATCH, or BBCS_CAUGHT */
3689     int catchDepth)             /* Depth of nesting of catches */
3690 {
3691     CompileEnv* envPtr = assemEnvPtr->envPtr;
3692                                 /* Compilation environment */
3693     Tcl_Interp* interp = (Tcl_Interp*) envPtr->iPtr;
3694                                 /* Tcl interpreter */
3695     int result;                 /* Return value from this procedure */
3696     BasicBlock* fallThruEnclosing;
3697                                 /* Enclosing catch if execution falls thru */
3698     enum BasicBlockCatchState fallThruState;
3699                                 /* Catch state of the successor block */
3700     BasicBlock* jumpEnclosing;  /* Enclosing catch if execution goes to jump
3701                                  * target */
3702     enum BasicBlockCatchState jumpState;
3703                                 /* Catch state of the jump target */
3704     int changed = 0;            /* Flag == 1 iff successor blocks need to be
3705                                  * checked because the state of this block has
3706                                  * changed. */
3707     BasicBlock* jumpTarget;     /* Basic block where a jump goes */
3708     Tcl_HashSearch jtSearch;    /* Hash search control for a jumptable */
3709     Tcl_HashEntry* jtEntry;     /* Entry in a jumptable */
3710     Tcl_Obj* targetLabel;       /* Target label from a jumptable */
3711     Tcl_HashEntry* entry;       /* Entry from the label table */
3712
3713     /*
3714      * Update the state of the current block, checking for consistency.  Set
3715      * 'changed' to 1 if the state changes and successor blocks need to be
3716      * rechecked.
3717      */
3718
3719     if (bbPtr->catchState == BBCS_UNKNOWN) {
3720         bbPtr->enclosingCatch = enclosing;
3721     } else if (bbPtr->enclosingCatch != enclosing) {
3722         if (assemEnvPtr->flags & TCL_EVAL_DIRECT) {
3723             Tcl_SetObjResult(interp, Tcl_NewStringObj(
3724                     "execution reaches an instruction in inconsistent "
3725                     "exception contexts", -1));
3726             Tcl_SetErrorLine(interp, bbPtr->startLine);
3727             Tcl_SetErrorCode(interp, "TCL", "ASSEM", "BADCATCH", NULL);
3728         }
3729         return TCL_ERROR;
3730     }
3731     if (state > bbPtr->catchState) {
3732         bbPtr->catchState = state;
3733         changed = 1;
3734     }
3735
3736     /*
3737      * If this block has been visited before, and its state hasn't changed,
3738      * we're done with it for now.
3739      */
3740
3741     if (!changed) {
3742         return TCL_OK;
3743     }
3744     bbPtr->catchDepth = catchDepth;
3745
3746     /*
3747      * Determine enclosing catch and 'caught' state for the fallthrough and
3748      * the jump target. Default for both is the state of the current block.
3749      */
3750
3751     fallThruEnclosing = enclosing;
3752     fallThruState = state;
3753     jumpEnclosing = enclosing;
3754     jumpState = state;
3755
3756     /*
3757      * TODO: Make sure that the test cases include validating that a natural
3758      * loop can't include 'beginCatch' or 'endCatch'
3759      */
3760
3761     if (bbPtr->flags & BB_BEGINCATCH) {
3762         /*
3763          * If the block begins a catch, the state for the successor is 'in
3764          * catch'. The jump target is the exception exit, and the state of the
3765          * jump target is 'caught.'
3766          */
3767
3768         fallThruEnclosing = bbPtr;
3769         fallThruState = BBCS_INCATCH;
3770         jumpEnclosing = bbPtr;
3771         jumpState = BBCS_CAUGHT;
3772         ++catchDepth;
3773     }
3774
3775     if (bbPtr->flags & BB_ENDCATCH) {
3776         /*
3777          * If the block ends a catch, the state for the successor is whatever
3778          * the state was on entry to the catch.
3779          */
3780
3781         if (enclosing == NULL) {
3782             if (assemEnvPtr->flags & TCL_EVAL_DIRECT) {
3783                 Tcl_SetObjResult(interp, Tcl_NewStringObj(
3784                         "endCatch without a corresponding beginCatch", -1));
3785                 Tcl_SetErrorLine(interp, bbPtr->startLine);
3786                 Tcl_SetErrorCode(interp, "TCL", "ASSEM", "BADENDCATCH", NULL);
3787             }
3788             return TCL_ERROR;
3789         }
3790         fallThruEnclosing = enclosing->enclosingCatch;
3791         fallThruState = enclosing->catchState;
3792         --catchDepth;
3793     }
3794
3795     /*
3796      * Visit any successor blocks with the appropriate exception context
3797      */
3798
3799     result = TCL_OK;
3800     if (bbPtr->flags & BB_FALLTHRU) {
3801         result = ProcessCatchesInBasicBlock(assemEnvPtr, bbPtr->successor1,
3802                 fallThruEnclosing, fallThruState, catchDepth);
3803     }
3804     if (result == TCL_OK && bbPtr->jumpTarget != NULL) {
3805         entry = Tcl_FindHashEntry(&assemEnvPtr->labelHash,
3806                 Tcl_GetString(bbPtr->jumpTarget));
3807         jumpTarget = (BasicBlock*)Tcl_GetHashValue(entry);
3808         result = ProcessCatchesInBasicBlock(assemEnvPtr, jumpTarget,
3809                 jumpEnclosing, jumpState, catchDepth);
3810     }
3811
3812     /*
3813      * All blocks referenced in a jump table are successors.
3814      */
3815
3816     if (bbPtr->flags & BB_JUMPTABLE) {
3817         for (jtEntry = Tcl_FirstHashEntry(&bbPtr->jtPtr->hashTable,&jtSearch);
3818                 result == TCL_OK && jtEntry != NULL;
3819                 jtEntry = Tcl_NextHashEntry(&jtSearch)) {
3820             targetLabel = (Tcl_Obj*)Tcl_GetHashValue(jtEntry);
3821             entry = Tcl_FindHashEntry(&assemEnvPtr->labelHash,
3822                     Tcl_GetString(targetLabel));
3823             jumpTarget = (BasicBlock*)Tcl_GetHashValue(entry);
3824             result = ProcessCatchesInBasicBlock(assemEnvPtr, jumpTarget,
3825                     jumpEnclosing, jumpState, catchDepth);
3826         }
3827     }
3828
3829     return result;
3830 }
3831 \f
3832 /*
3833  *-----------------------------------------------------------------------------
3834  *
3835  * CheckForUnclosedCatches --
3836  *
3837  *      Checks that a sequence of assembly code has no unclosed catches on
3838  *      exit.
3839  *
3840  * Results:
3841  *      Returns a standard Tcl result, with an error message for unclosed
3842  *      catches.
3843  *
3844  *-----------------------------------------------------------------------------
3845  */
3846
3847 static int
3848 CheckForUnclosedCatches(
3849     AssemblyEnv* assemEnvPtr)   /* Assembly environment */
3850 {
3851     CompileEnv* envPtr = assemEnvPtr->envPtr;
3852                                 /* Compilation environment */
3853     Tcl_Interp* interp = (Tcl_Interp*) envPtr->iPtr;
3854                                 /* Tcl interpreter */
3855
3856     if (assemEnvPtr->curr_bb->catchState >= BBCS_INCATCH) {
3857         if (assemEnvPtr->flags & TCL_EVAL_DIRECT) {
3858             Tcl_SetObjResult(interp, Tcl_NewStringObj(
3859                     "catch still active on exit from assembly code", -1));
3860             Tcl_SetErrorLine(interp,
3861                     assemEnvPtr->curr_bb->enclosingCatch->startLine);
3862             Tcl_SetErrorCode(interp, "TCL", "ASSEM", "UNCLOSEDCATCH", NULL);
3863         }
3864         return TCL_ERROR;
3865     }
3866     return TCL_OK;
3867 }
3868 \f
3869 /*
3870  *-----------------------------------------------------------------------------
3871  *
3872  * BuildExceptionRanges --
3873  *
3874  *      Walks through the assembly code and builds exception ranges for the
3875  *      catches embedded therein.
3876  *
3877  * Results:
3878  *      Returns a standard Tcl result with an error message in the interpreter
3879  *      if anything is unsuccessful.
3880  *
3881  * Side effects:
3882  *      Each contiguous block of code with a given catch exit is assigned an
3883  *      exception range at the appropriate level.
3884  *      Exception ranges in embedded blocks have their levels corrected and
3885  *      collated into the table.
3886  *      Blocks that end with 'beginCatch' are associated with the innermost
3887  *      exception range of the following block.
3888  *
3889  *-----------------------------------------------------------------------------
3890  */
3891
3892 static int
3893 BuildExceptionRanges(
3894     AssemblyEnv* assemEnvPtr)   /* Assembly environment */
3895 {
3896     CompileEnv* envPtr = assemEnvPtr->envPtr;
3897                                 /* Compilation environment */
3898     BasicBlock* bbPtr;          /* Current basic block */
3899     BasicBlock* prevPtr = NULL; /* Previous basic block */
3900     int catchDepth = 0;         /* Current catch depth */
3901     int maxCatchDepth = 0;      /* Maximum catch depth in the program */
3902     BasicBlock** catches;       /* Stack of catches in progress */
3903     int* catchIndices;          /* Indices of the exception ranges of catches
3904                                  * in progress */
3905     int i;
3906
3907     /*
3908      * Determine the max catch depth for the entire assembly script
3909      * (excluding embedded eval's and expr's, which will be handled later).
3910      */
3911
3912     for (bbPtr=assemEnvPtr->head_bb; bbPtr != NULL; bbPtr=bbPtr->successor1) {
3913         if (bbPtr->catchDepth > maxCatchDepth) {
3914             maxCatchDepth = bbPtr->catchDepth;
3915         }
3916     }
3917
3918     /*
3919      * Allocate memory for a stack of active catches.
3920      */
3921
3922     catches = (BasicBlock**)ckalloc(maxCatchDepth * sizeof(BasicBlock*));
3923     catchIndices = (int *)ckalloc(maxCatchDepth * sizeof(int));
3924     for (i = 0; i < maxCatchDepth; ++i) {
3925         catches[i] = NULL;
3926         catchIndices[i] = -1;
3927     }
3928
3929     /*
3930      * Walk through the basic blocks and manage exception ranges.
3931      */
3932
3933     for (bbPtr=assemEnvPtr->head_bb; bbPtr != NULL; bbPtr=bbPtr->successor1) {
3934         UnstackExpiredCatches(envPtr, bbPtr, catchDepth, catches,
3935                 catchIndices);
3936         LookForFreshCatches(bbPtr, catches);
3937         StackFreshCatches(assemEnvPtr, bbPtr, catchDepth, catches,
3938                 catchIndices);
3939
3940         /*
3941          * If the last block was a 'begin catch', fill in the exception range.
3942          */
3943
3944         catchDepth = bbPtr->catchDepth;
3945         if (prevPtr != NULL && (prevPtr->flags & BB_BEGINCATCH)) {
3946             TclStoreInt4AtPtr(catchIndices[catchDepth-1],
3947                     envPtr->codeStart + bbPtr->startOffset - 4);
3948         }
3949
3950         prevPtr = bbPtr;
3951     }
3952
3953     /* Make sure that all catches are closed */
3954
3955     if (catchDepth != 0) {
3956         Tcl_Panic("unclosed catch at end of code in "
3957                 "tclAssembly.c:BuildExceptionRanges, can't happen");
3958     }
3959
3960     /* Free temp storage */
3961
3962     ckfree(catchIndices);
3963     ckfree(catches);
3964
3965     return TCL_OK;
3966 }
3967 \f
3968 /*
3969  *-----------------------------------------------------------------------------
3970  *
3971  * UnstackExpiredCatches --
3972  *
3973  *      Unstacks and closes the exception ranges for any catch contexts that
3974  *      were active in the previous basic block but are inactive in the
3975  *      current one.
3976  *
3977  *-----------------------------------------------------------------------------
3978  */
3979
3980 static void
3981 UnstackExpiredCatches(
3982     CompileEnv* envPtr,         /* Compilation environment */
3983     BasicBlock* bbPtr,          /* Basic block being processed */
3984     int catchDepth,             /* Depth of nesting of catches prior to entry
3985                                  * to this block */
3986     BasicBlock** catches,       /* Array of catch contexts */
3987     int* catchIndices)          /* Indices of the exception ranges
3988                                  * corresponding to the catch contexts */
3989 {
3990     ExceptionRange* range;      /* Exception range for a specific catch */
3991     BasicBlock* block;          /* Catch block being examined */
3992     BasicBlockCatchState catchState;
3993                                 /* State of the code relative to the catch
3994                                  * block being examined ("in catch" or
3995                                  * "caught"). */
3996
3997     /*
3998      * Unstack any catches that are deeper than the nesting level of the basic
3999      * block being entered.
4000      */
4001
4002     while (catchDepth > bbPtr->catchDepth) {
4003         --catchDepth;
4004         if (catches[catchDepth] != NULL) {
4005             range = envPtr->exceptArrayPtr + catchIndices[catchDepth];
4006             range->numCodeBytes = bbPtr->startOffset - range->codeOffset;
4007             catches[catchDepth] = NULL;
4008             catchIndices[catchDepth] = -1;
4009         }
4010     }
4011
4012     /*
4013      * Unstack any catches that don't match the basic block being entered,
4014      * either because they are no longer part of the context, or because the
4015      * context has changed from INCATCH to CAUGHT.
4016      */
4017
4018     catchState = bbPtr->catchState;
4019     block = bbPtr->enclosingCatch;
4020     while (catchDepth > 0) {
4021         --catchDepth;
4022         if (catches[catchDepth] != NULL) {
4023             if (catches[catchDepth] != block || catchState >= BBCS_CAUGHT) {
4024                 range = envPtr->exceptArrayPtr + catchIndices[catchDepth];
4025                 range->numCodeBytes = bbPtr->startOffset - range->codeOffset;
4026                 catches[catchDepth] = NULL;
4027                 catchIndices[catchDepth] = -1;
4028             }
4029             catchState = block->catchState;
4030             block = block->enclosingCatch;
4031         }
4032     }
4033 }
4034 \f
4035 /*
4036  *-----------------------------------------------------------------------------
4037  *
4038  * LookForFreshCatches --
4039  *
4040  *      Determines whether a basic block being entered needs any exception
4041  *      ranges that are not already stacked.
4042  *
4043  * Does not create the ranges: this procedure iterates from the innermost
4044  * catch outward, but exception ranges must be created from the outermost
4045  * catch inward.
4046  *
4047  *-----------------------------------------------------------------------------
4048  */
4049
4050 static void
4051 LookForFreshCatches(
4052     BasicBlock* bbPtr,          /* Basic block being entered */
4053     BasicBlock** catches)       /* Array of catch contexts that are already
4054                                  * entered */
4055 {
4056     BasicBlockCatchState catchState;
4057                                 /* State ("in catch" or "caught") of the
4058                                  * current catch. */
4059     BasicBlock* block;          /* Current enclosing catch */
4060     int catchDepth;             /* Nesting depth of the current catch */
4061
4062     catchState = bbPtr->catchState;
4063     block = bbPtr->enclosingCatch;
4064     catchDepth = bbPtr->catchDepth;
4065     while (catchDepth > 0) {
4066         --catchDepth;
4067         if (catches[catchDepth] != block && catchState < BBCS_CAUGHT) {
4068             catches[catchDepth] = block;
4069         }
4070         catchState = block->catchState;
4071         block = block->enclosingCatch;
4072     }
4073 }
4074 \f
4075 /*
4076  *-----------------------------------------------------------------------------
4077  *
4078  * StackFreshCatches --
4079  *
4080  *      Make ExceptionRange records for any catches that are in the basic
4081  *      block being entered and were not in the previous basic block.
4082  *
4083  *-----------------------------------------------------------------------------
4084  */
4085
4086 static void
4087 StackFreshCatches(
4088     AssemblyEnv* assemEnvPtr,   /* Assembly environment */
4089     BasicBlock* bbPtr,          /* Basic block being processed */
4090     int catchDepth,             /* Depth of nesting of catches prior to entry
4091                                  * to this block */
4092     BasicBlock** catches,       /* Array of catch contexts */
4093     int* catchIndices)          /* Indices of the exception ranges
4094                                  * corresponding to the catch contexts */
4095 {
4096     CompileEnv* envPtr = assemEnvPtr->envPtr;
4097                                 /* Compilation environment */
4098     ExceptionRange* range;      /* Exception range for a specific catch */
4099     BasicBlock* block;          /* Catch block being examined */
4100     BasicBlock* errorExit;      /* Error exit from the catch block */
4101     Tcl_HashEntry* entryPtr;
4102
4103     catchDepth = 0;
4104
4105     /*
4106      * Iterate through the enclosing catch blocks from the outside in,
4107      * looking for ones that don't have exception ranges (and are uncaught)
4108      */
4109
4110     for (catchDepth = 0; catchDepth < bbPtr->catchDepth; ++catchDepth) {
4111         if (catchIndices[catchDepth] == -1 && catches[catchDepth] != NULL) {
4112             /*
4113              * Create an exception range for a block that needs one.
4114              */
4115
4116             block = catches[catchDepth];
4117             catchIndices[catchDepth] =
4118                     TclCreateExceptRange(CATCH_EXCEPTION_RANGE, envPtr);
4119             range = envPtr->exceptArrayPtr + catchIndices[catchDepth];
4120             range->nestingLevel = envPtr->exceptDepth + catchDepth;
4121             envPtr->maxExceptDepth =
4122                     TclMax(range->nestingLevel + 1, envPtr->maxExceptDepth);
4123             range->codeOffset = bbPtr->startOffset;
4124
4125             entryPtr = Tcl_FindHashEntry(&assemEnvPtr->labelHash,
4126                     Tcl_GetString(block->jumpTarget));
4127             if (entryPtr == NULL) {
4128                 Tcl_Panic("undefined label in tclAssembly.c:"
4129                         "BuildExceptionRanges, can't happen");
4130             }
4131
4132             errorExit = (BasicBlock*)Tcl_GetHashValue(entryPtr);
4133             range->catchOffset = errorExit->startOffset;
4134         }
4135     }
4136 }
4137 \f
4138 /*
4139  *-----------------------------------------------------------------------------
4140  *
4141  * RestoreEmbeddedExceptionRanges --
4142  *
4143  *      Processes an assembly script, replacing any exception ranges that
4144  *      were present in embedded code.
4145  *
4146  *-----------------------------------------------------------------------------
4147  */
4148
4149 static void
4150 RestoreEmbeddedExceptionRanges(
4151     AssemblyEnv* assemEnvPtr)   /* Assembly environment */
4152 {
4153     CompileEnv* envPtr = assemEnvPtr->envPtr;
4154                                 /* Compilation environment */
4155     BasicBlock* bbPtr;          /* Current basic block */
4156     int rangeBase;              /* Base of the foreign exception ranges when
4157                                  * they are reinstalled */
4158     int rangeIndex;             /* Index of the current foreign exception
4159                                  * range as reinstalled */
4160     ExceptionRange* range;      /* Current foreign exception range */
4161     unsigned char opcode;       /* Current instruction's opcode */
4162     int catchIndex;             /* Index of the exception range to which the
4163                                  * current instruction refers */
4164     int i;
4165
4166     /*
4167      * Walk the basic blocks looking for exceptions in embedded scripts.
4168      */
4169
4170     for (bbPtr = assemEnvPtr->head_bb;
4171             bbPtr != NULL;
4172             bbPtr = bbPtr->successor1) {
4173         if (bbPtr->foreignExceptionCount != 0) {
4174             /*
4175              * Reinstall the embedded exceptions and track their nesting level
4176              */
4177
4178             rangeBase = envPtr->exceptArrayNext;
4179             for (i = 0; i < bbPtr->foreignExceptionCount; ++i) {
4180                 range = bbPtr->foreignExceptions + i;
4181                 rangeIndex = TclCreateExceptRange(range->type, envPtr);
4182                 range->nestingLevel += envPtr->exceptDepth + bbPtr->catchDepth;
4183                 memcpy(envPtr->exceptArrayPtr + rangeIndex, range,
4184                         sizeof(ExceptionRange));
4185                 if (range->nestingLevel >= envPtr->maxExceptDepth) {
4186                     envPtr->maxExceptDepth = range->nestingLevel + 1;
4187                 }
4188             }
4189
4190             /*
4191              * Walk through the bytecode of the basic block, and relocate
4192              * INST_BEGIN_CATCH4 instructions to the new locations
4193              */
4194
4195             i = bbPtr->startOffset;
4196             while (i < bbPtr->successor1->startOffset) {
4197                 opcode = envPtr->codeStart[i];
4198                 if (opcode == INST_BEGIN_CATCH4) {
4199                     catchIndex = TclGetUInt4AtPtr(envPtr->codeStart + i + 1);
4200                     if (catchIndex >= bbPtr->foreignExceptionBase
4201                             && catchIndex < (bbPtr->foreignExceptionBase +
4202                             bbPtr->foreignExceptionCount)) {
4203                         catchIndex -= bbPtr->foreignExceptionBase;
4204                         catchIndex += rangeBase;
4205                         TclStoreInt4AtPtr(catchIndex, envPtr->codeStart+i+1);
4206                     }
4207                 }
4208                 i += tclInstructionTable[opcode].numBytes;
4209             }
4210         }
4211     }
4212 }
4213 \f
4214 /*
4215  *-----------------------------------------------------------------------------
4216  *
4217  * ResetVisitedBasicBlocks --
4218  *
4219  *      Turns off the 'visited' flag in all basic blocks at the conclusion
4220  *      of a pass.
4221  *
4222  *-----------------------------------------------------------------------------
4223  */
4224
4225 static void
4226 ResetVisitedBasicBlocks(
4227     AssemblyEnv* assemEnvPtr)   /* Assembly environment */
4228 {
4229     BasicBlock* block;
4230
4231     for (block = assemEnvPtr->head_bb; block != NULL;
4232             block = block->successor1) {
4233         block->flags &= ~BB_VISITED;
4234     }
4235 }
4236 \f
4237 /*
4238  *-----------------------------------------------------------------------------
4239  *
4240  * AddBasicBlockRangeToErrorInfo --
4241  *
4242  *      Updates the error info of the Tcl interpreter to show a given basic
4243  *      block in the code.
4244  *
4245  * This procedure is used to label the callstack with source location
4246  * information when reporting an error in stack checking.
4247  *
4248  *-----------------------------------------------------------------------------
4249  */
4250
4251 static void
4252 AddBasicBlockRangeToErrorInfo(
4253     AssemblyEnv* assemEnvPtr,   /* Assembly environment */
4254     BasicBlock* bbPtr)          /* Basic block in which the error is found */
4255 {
4256     CompileEnv* envPtr = assemEnvPtr->envPtr;
4257                                 /* Compilation environment */
4258     Tcl_Interp* interp = (Tcl_Interp*) envPtr->iPtr;
4259                                 /* Tcl interpreter */
4260     Tcl_Obj* lineNo;            /* Line number in the source */
4261
4262     Tcl_AddErrorInfo(interp, "\n    in assembly code between lines ");
4263     TclNewIntObj(lineNo, bbPtr->startLine);
4264     Tcl_IncrRefCount(lineNo);
4265     Tcl_AppendObjToErrorInfo(interp, lineNo);
4266     Tcl_AddErrorInfo(interp, " and ");
4267     if (bbPtr->successor1 != NULL) {
4268         Tcl_SetIntObj(lineNo, bbPtr->successor1->startLine);
4269         Tcl_AppendObjToErrorInfo(interp, lineNo);
4270     } else {
4271         Tcl_AddErrorInfo(interp, "end of assembly code");
4272     }
4273     Tcl_DecrRefCount(lineNo);
4274 }
4275 \f
4276 /*
4277  *-----------------------------------------------------------------------------
4278  *
4279  * DupAssembleCodeInternalRep --
4280  *
4281  *      Part of the Tcl object type implementation for Tcl assembly language
4282  *      bytecode. We do not copy the bytecode internalrep. Instead, we return
4283  *      without setting copyPtr->typePtr, so the copy is a plain string copy
4284  *      of the assembly source, and if it is to be used as a compiled
4285  *      expression, it will need to be reprocessed.
4286  *
4287  *      This makes sense, because with Tcl's copy-on-write practices, the
4288  *      usual (only?) time Tcl_DuplicateObj() will be called is when the copy
4289  *      is about to be modified, which would invalidate any copied bytecode
4290  *      anyway. The only reason it might make sense to copy the bytecode is if
4291  *      we had some modifying routines that operated directly on the internalrep,
4292  *      as we do for lists and dicts.
4293  *
4294  * Results:
4295  *      None.
4296  *
4297  * Side effects:
4298  *      None.
4299  *
4300  *-----------------------------------------------------------------------------
4301  */
4302
4303 static void
4304 DupAssembleCodeInternalRep(
4305     Tcl_Obj *srcPtr,
4306     Tcl_Obj *copyPtr)
4307 {
4308     (void)srcPtr;
4309     (void)copyPtr;
4310
4311     return;
4312 }
4313 \f
4314 /*
4315  *-----------------------------------------------------------------------------
4316  *
4317  * FreeAssembleCodeInternalRep --
4318  *
4319  *      Part of the Tcl object type implementation for Tcl expression
4320  *      bytecode. Frees the storage allocated to hold the internal rep, unless
4321  *      ref counts indicate bytecode execution is still in progress.
4322  *
4323  * Results:
4324  *      None.
4325  *
4326  * Side effects:
4327  *      May free allocated memory. Leaves objPtr untyped.
4328  *
4329  *-----------------------------------------------------------------------------
4330  */
4331
4332 static void
4333 FreeAssembleCodeInternalRep(
4334     Tcl_Obj *objPtr)
4335 {
4336     ByteCode *codePtr = (ByteCode *)objPtr->internalRep.twoPtrValue.ptr1;
4337
4338     if (codePtr->refCount-- <= 1) {
4339         TclCleanupByteCode(codePtr);
4340     }
4341     objPtr->typePtr = NULL;
4342 }
4343 \f
4344 /*
4345  * Local Variables:
4346  * mode: c
4347  * c-basic-offset: 4
4348  * fill-column: 78
4349  * End:
4350  */