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
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
BBAdjustStackDepth(BasicBlock * bbPtr,int consumed,int produced)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
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
BBUpdateStackReqs(BasicBlock * bbPtr,int tblIdx,int count)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
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
BBEmitOpcode(AssemblyEnv * assemEnvPtr,int tblIdx,int count)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
BBEmitInstInt1(AssemblyEnv * assemEnvPtr,int tblIdx,int opnd,int count)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
BBEmitInstInt4(AssemblyEnv * assemEnvPtr,int tblIdx,int opnd,int count)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
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
BBEmitInst1or4(AssemblyEnv * assemEnvPtr,int tblIdx,int param,int count)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
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
Tcl_AssembleObjCmd(ClientData dummy,Tcl_Interp * interp,int objc,Tcl_Obj * const objv[])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
TclNRAssembleObjCmd(ClientData dummy,Tcl_Interp * interp,int objc,Tcl_Obj * const objv[])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
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 *
CompileAssembleObj(Tcl_Interp * interp,Tcl_Obj * objPtr)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
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
TclCompileAssembleCmd(Tcl_Interp * interp,Tcl_Parse * parsePtr,Command * cmdPtr,CompileEnv * envPtr)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
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
TclAssembleCode(CompileEnv * envPtr,const char * codePtr,int codeLen,int flags)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
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*
NewAssemblyEnv(CompileEnv * envPtr,int flags)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
1179 /*
1180 *-----------------------------------------------------------------------------
1181 *
1182 * FreeAssemblyEnv --
1183 *
1184 * Cleans up the assembler environment when assembly is complete.
1185 *
1186 *-----------------------------------------------------------------------------
1187 */
1188
1189 static void
FreeAssemblyEnv(AssemblyEnv * assemEnvPtr)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
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
AssembleOneLine(AssemblyEnv * assemEnvPtr)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
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
CompileEmbeddedScript(AssemblyEnv * assemEnvPtr,Tcl_Token * tokenPtr,const TalInstDesc * instPtr)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
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
SyncStackDepth(AssemblyEnv * assemEnvPtr)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
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
MoveExceptionRangesToBasicBlock(AssemblyEnv * assemEnvPtr,int savedExceptArrayNext)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
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
CreateMirrorJumpTable(AssemblyEnv * assemEnvPtr,Tcl_Obj * jumps)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
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
DeleteMirrorJumpTable(JumptableInfo * jtPtr)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
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
GetNextOperand(AssemblyEnv * assemEnvPtr,Tcl_Token ** tokenPtrPtr,Tcl_Obj ** operandObjPtr)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
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
GetBooleanOperand(AssemblyEnv * assemEnvPtr,Tcl_Token ** tokenPtrPtr,int * result)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
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
GetIntegerOperand(AssemblyEnv * assemEnvPtr,Tcl_Token ** tokenPtrPtr,int * result)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
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
GetListIndexOperand(AssemblyEnv * assemEnvPtr,Tcl_Token ** tokenPtrPtr,int * result)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
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
FindLocalVar(AssemblyEnv * assemEnvPtr,Tcl_Token ** tokenPtrPtr)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
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
CheckNamespaceQualifiers(Tcl_Interp * interp,const char * name,int nameLen)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
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
CheckOneByte(Tcl_Interp * interp,int value)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
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
CheckSignedOneByte(Tcl_Interp * interp,int value)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
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
CheckNonNegative(Tcl_Interp * interp,int value)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
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
CheckStrictlyPositive(Tcl_Interp * interp,int value)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
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
DefineLabel(AssemblyEnv * assemEnvPtr,const char * labelName)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
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*
StartBasicBlock(AssemblyEnv * assemEnvPtr,int flags,Tcl_Obj * jumpLabel)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
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 *
AllocBB(AssemblyEnv * assemEnvPtr)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
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
FinishAssembly(AssemblyEnv * assemEnvPtr)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
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
CalculateJumpRelocations(AssemblyEnv * assemEnvPtr,int * mustMove)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
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
CheckJumpTableLabels(AssemblyEnv * assemEnvPtr,BasicBlock * bbPtr)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
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
ReportUndefinedLabel(AssemblyEnv * assemEnvPtr,BasicBlock * bbPtr,Tcl_Obj * jumpTarget)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
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
MoveCodeForJumps(AssemblyEnv * assemEnvPtr,int mustMove)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
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
FillInJumpOffsets(AssemblyEnv * assemEnvPtr)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
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
ResolveJumpTableTargets(AssemblyEnv * assemEnvPtr,BasicBlock * bbPtr)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
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
CheckForThrowInWrongContext(AssemblyEnv * assemEnvPtr)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
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
CheckNonThrowingBlock(AssemblyEnv * assemEnvPtr,BasicBlock * blockPtr)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
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
BytecodeMightThrow(unsigned char opcode)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
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
CheckStack(AssemblyEnv * assemEnvPtr)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
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
StackCheckBasicBlock(AssemblyEnv * assemEnvPtr,BasicBlock * blockPtr,BasicBlock * predecessor,int initialStackDepth)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
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
StackCheckExit(AssemblyEnv * assemEnvPtr)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
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
ProcessCatches(AssemblyEnv * assemEnvPtr)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
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
ProcessCatchesInBasicBlock(AssemblyEnv * assemEnvPtr,BasicBlock * bbPtr,BasicBlock * enclosing,enum BasicBlockCatchState state,int catchDepth)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
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
CheckForUnclosedCatches(AssemblyEnv * assemEnvPtr)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
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
BuildExceptionRanges(AssemblyEnv * assemEnvPtr)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
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
UnstackExpiredCatches(CompileEnv * envPtr,BasicBlock * bbPtr,int catchDepth,BasicBlock ** catches,int * catchIndices)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
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
LookForFreshCatches(BasicBlock * bbPtr,BasicBlock ** catches)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
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
StackFreshCatches(AssemblyEnv * assemEnvPtr,BasicBlock * bbPtr,int catchDepth,BasicBlock ** catches,int * catchIndices)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
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
RestoreEmbeddedExceptionRanges(AssemblyEnv * assemEnvPtr)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
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
ResetVisitedBasicBlocks(AssemblyEnv * assemEnvPtr)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
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
AddBasicBlockRangeToErrorInfo(AssemblyEnv * assemEnvPtr,BasicBlock * bbPtr)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
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
DupAssembleCodeInternalRep(Tcl_Obj * srcPtr,Tcl_Obj * copyPtr)4304 DupAssembleCodeInternalRep(
4305 Tcl_Obj *srcPtr,
4306 Tcl_Obj *copyPtr)
4307 {
4308 (void)srcPtr;
4309 (void)copyPtr;
4310
4311 return;
4312 }
4313
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
FreeAssembleCodeInternalRep(Tcl_Obj * objPtr)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
4344 /*
4345 * Local Variables:
4346 * mode: c
4347 * c-basic-offset: 4
4348 * fill-column: 78
4349 * End:
4350 */
4351