1 /*
2 * tclCompile.c --
3 *
4 * This file contains procedures that compile Tcl commands or parts of
5 * commands (like quoted strings or nested sub-commands) into a sequence
6 * of instructions ("bytecodes").
7 *
8 * Copyright (c) 1996-1998 Sun Microsystems, Inc.
9 * Copyright (c) 2001 by Kevin B. Kenny. All rights reserved.
10 *
11 * See the file "license.terms" for information on usage and redistribution of
12 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
13 */
14
15 #include "tclInt.h"
16 #include "tclCompile.h"
17 #include <assert.h>
18
19 /*
20 * Variable that controls whether compilation tracing is enabled and, if so,
21 * what level of tracing is desired:
22 * 0: no compilation tracing
23 * 1: summarize compilation of top level cmds and proc bodies
24 * 2: display all instructions of each ByteCode compiled
25 * This variable is linked to the Tcl variable "tcl_traceCompile".
26 */
27
28 #ifdef TCL_COMPILE_DEBUG
29 int tclTraceCompile = 0;
30 static int traceInitialized = 0;
31 #endif
32
33 /*
34 * A table describing the Tcl bytecode instructions. Entries in this table
35 * must correspond to the instruction opcode definitions in tclCompile.h. The
36 * names "op1" and "op4" refer to an instruction's one or four byte first
37 * operand. Similarly, "stktop" and "stknext" refer to the topmost and next to
38 * topmost stack elements.
39 *
40 * Note that the load, store, and incr instructions do not distinguish local
41 * from global variables; the bytecode interpreter at runtime uses the
42 * existence of a procedure call frame to distinguish these.
43 */
44
45 InstructionDesc const tclInstructionTable[] = {
46 /* Name Bytes stackEffect #Opnds Operand types */
47 {"done", 1, -1, 0, {OPERAND_NONE}},
48 /* Finish ByteCode execution and return stktop (top stack item) */
49 {"push1", 2, +1, 1, {OPERAND_LIT1}},
50 /* Push object at ByteCode objArray[op1] */
51 {"push4", 5, +1, 1, {OPERAND_LIT4}},
52 /* Push object at ByteCode objArray[op4] */
53 {"pop", 1, -1, 0, {OPERAND_NONE}},
54 /* Pop the topmost stack object */
55 {"dup", 1, +1, 0, {OPERAND_NONE}},
56 /* Duplicate the topmost stack object and push the result */
57 {"strcat", 2, INT_MIN, 1, {OPERAND_UINT1}},
58 /* Concatenate the top op1 items and push result */
59 {"invokeStk1", 2, INT_MIN, 1, {OPERAND_UINT1}},
60 /* Invoke command named objv[0]; <objc,objv> = <op1,top op1> */
61 {"invokeStk4", 5, INT_MIN, 1, {OPERAND_UINT4}},
62 /* Invoke command named objv[0]; <objc,objv> = <op4,top op4> */
63 {"evalStk", 1, 0, 0, {OPERAND_NONE}},
64 /* Evaluate command in stktop using Tcl_EvalObj. */
65 {"exprStk", 1, 0, 0, {OPERAND_NONE}},
66 /* Execute expression in stktop using Tcl_ExprStringObj. */
67
68 {"loadScalar1", 2, 1, 1, {OPERAND_LVT1}},
69 /* Load scalar variable at index op1 <= 255 in call frame */
70 {"loadScalar4", 5, 1, 1, {OPERAND_LVT4}},
71 /* Load scalar variable at index op1 >= 256 in call frame */
72 {"loadScalarStk", 1, 0, 0, {OPERAND_NONE}},
73 /* Load scalar variable; scalar's name is stktop */
74 {"loadArray1", 2, 0, 1, {OPERAND_LVT1}},
75 /* Load array element; array at slot op1<=255, element is stktop */
76 {"loadArray4", 5, 0, 1, {OPERAND_LVT4}},
77 /* Load array element; array at slot op1 > 255, element is stktop */
78 {"loadArrayStk", 1, -1, 0, {OPERAND_NONE}},
79 /* Load array element; element is stktop, array name is stknext */
80 {"loadStk", 1, 0, 0, {OPERAND_NONE}},
81 /* Load general variable; unparsed variable name is stktop */
82 {"storeScalar1", 2, 0, 1, {OPERAND_LVT1}},
83 /* Store scalar variable at op1<=255 in frame; value is stktop */
84 {"storeScalar4", 5, 0, 1, {OPERAND_LVT4}},
85 /* Store scalar variable at op1 > 255 in frame; value is stktop */
86 {"storeScalarStk", 1, -1, 0, {OPERAND_NONE}},
87 /* Store scalar; value is stktop, scalar name is stknext */
88 {"storeArray1", 2, -1, 1, {OPERAND_LVT1}},
89 /* Store array element; array at op1<=255, value is top then elem */
90 {"storeArray4", 5, -1, 1, {OPERAND_LVT4}},
91 /* Store array element; array at op1>=256, value is top then elem */
92 {"storeArrayStk", 1, -2, 0, {OPERAND_NONE}},
93 /* Store array element; value is stktop, then elem, array names */
94 {"storeStk", 1, -1, 0, {OPERAND_NONE}},
95 /* Store general variable; value is stktop, then unparsed name */
96
97 {"incrScalar1", 2, 0, 1, {OPERAND_LVT1}},
98 /* Incr scalar at index op1<=255 in frame; incr amount is stktop */
99 {"incrScalarStk", 1, -1, 0, {OPERAND_NONE}},
100 /* Incr scalar; incr amount is stktop, scalar's name is stknext */
101 {"incrArray1", 2, -1, 1, {OPERAND_LVT1}},
102 /* Incr array elem; arr at slot op1<=255, amount is top then elem */
103 {"incrArrayStk", 1, -2, 0, {OPERAND_NONE}},
104 /* Incr array element; amount is top then elem then array names */
105 {"incrStk", 1, -1, 0, {OPERAND_NONE}},
106 /* Incr general variable; amount is stktop then unparsed var name */
107 {"incrScalar1Imm", 3, +1, 2, {OPERAND_LVT1, OPERAND_INT1}},
108 /* Incr scalar at slot op1 <= 255; amount is 2nd operand byte */
109 {"incrScalarStkImm", 2, 0, 1, {OPERAND_INT1}},
110 /* Incr scalar; scalar name is stktop; incr amount is op1 */
111 {"incrArray1Imm", 3, 0, 2, {OPERAND_LVT1, OPERAND_INT1}},
112 /* Incr array elem; array at slot op1 <= 255, elem is stktop,
113 * amount is 2nd operand byte */
114 {"incrArrayStkImm", 2, -1, 1, {OPERAND_INT1}},
115 /* Incr array element; elem is top then array name, amount is op1 */
116 {"incrStkImm", 2, 0, 1, {OPERAND_INT1}},
117 /* Incr general variable; unparsed name is top, amount is op1 */
118
119 {"jump1", 2, 0, 1, {OPERAND_OFFSET1}},
120 /* Jump relative to (pc + op1) */
121 {"jump4", 5, 0, 1, {OPERAND_OFFSET4}},
122 /* Jump relative to (pc + op4) */
123 {"jumpTrue1", 2, -1, 1, {OPERAND_OFFSET1}},
124 /* Jump relative to (pc + op1) if stktop expr object is true */
125 {"jumpTrue4", 5, -1, 1, {OPERAND_OFFSET4}},
126 /* Jump relative to (pc + op4) if stktop expr object is true */
127 {"jumpFalse1", 2, -1, 1, {OPERAND_OFFSET1}},
128 /* Jump relative to (pc + op1) if stktop expr object is false */
129 {"jumpFalse4", 5, -1, 1, {OPERAND_OFFSET4}},
130 /* Jump relative to (pc + op4) if stktop expr object is false */
131
132 {"lor", 1, -1, 0, {OPERAND_NONE}},
133 /* Logical or: push (stknext || stktop) */
134 {"land", 1, -1, 0, {OPERAND_NONE}},
135 /* Logical and: push (stknext && stktop) */
136 {"bitor", 1, -1, 0, {OPERAND_NONE}},
137 /* Bitwise or: push (stknext | stktop) */
138 {"bitxor", 1, -1, 0, {OPERAND_NONE}},
139 /* Bitwise xor push (stknext ^ stktop) */
140 {"bitand", 1, -1, 0, {OPERAND_NONE}},
141 /* Bitwise and: push (stknext & stktop) */
142 {"eq", 1, -1, 0, {OPERAND_NONE}},
143 /* Equal: push (stknext == stktop) */
144 {"neq", 1, -1, 0, {OPERAND_NONE}},
145 /* Not equal: push (stknext != stktop) */
146 {"lt", 1, -1, 0, {OPERAND_NONE}},
147 /* Less: push (stknext < stktop) */
148 {"gt", 1, -1, 0, {OPERAND_NONE}},
149 /* Greater: push (stknext > stktop) */
150 {"le", 1, -1, 0, {OPERAND_NONE}},
151 /* Less or equal: push (stknext <= stktop) */
152 {"ge", 1, -1, 0, {OPERAND_NONE}},
153 /* Greater or equal: push (stknext >= stktop) */
154 {"lshift", 1, -1, 0, {OPERAND_NONE}},
155 /* Left shift: push (stknext << stktop) */
156 {"rshift", 1, -1, 0, {OPERAND_NONE}},
157 /* Right shift: push (stknext >> stktop) */
158 {"add", 1, -1, 0, {OPERAND_NONE}},
159 /* Add: push (stknext + stktop) */
160 {"sub", 1, -1, 0, {OPERAND_NONE}},
161 /* Sub: push (stkext - stktop) */
162 {"mult", 1, -1, 0, {OPERAND_NONE}},
163 /* Multiply: push (stknext * stktop) */
164 {"div", 1, -1, 0, {OPERAND_NONE}},
165 /* Divide: push (stknext / stktop) */
166 {"mod", 1, -1, 0, {OPERAND_NONE}},
167 /* Mod: push (stknext % stktop) */
168 {"uplus", 1, 0, 0, {OPERAND_NONE}},
169 /* Unary plus: push +stktop */
170 {"uminus", 1, 0, 0, {OPERAND_NONE}},
171 /* Unary minus: push -stktop */
172 {"bitnot", 1, 0, 0, {OPERAND_NONE}},
173 /* Bitwise not: push ~stktop */
174 {"not", 1, 0, 0, {OPERAND_NONE}},
175 /* Logical not: push !stktop */
176 {"callBuiltinFunc1", 2, 1, 1, {OPERAND_UINT1}},
177 /* Call builtin math function with index op1; any args are on stk */
178 {"callFunc1", 2, INT_MIN, 1, {OPERAND_UINT1}},
179 /* Call non-builtin func objv[0]; <objc,objv>=<op1,top op1> */
180 {"tryCvtToNumeric", 1, 0, 0, {OPERAND_NONE}},
181 /* Try converting stktop to first int then double if possible. */
182
183 {"break", 1, 0, 0, {OPERAND_NONE}},
184 /* Abort closest enclosing loop; if none, return TCL_BREAK code. */
185 {"continue", 1, 0, 0, {OPERAND_NONE}},
186 /* Skip to next iteration of closest enclosing loop; if none, return
187 * TCL_CONTINUE code. */
188
189 {"foreach_start4", 5, 0, 1, {OPERAND_AUX4}},
190 /* Initialize execution of a foreach loop. Operand is aux data index
191 * of the ForeachInfo structure for the foreach command. */
192 {"foreach_step4", 5, +1, 1, {OPERAND_AUX4}},
193 /* "Step" or begin next iteration of foreach loop. Push 0 if to
194 * terminate loop, else push 1. */
195
196 {"beginCatch4", 5, 0, 1, {OPERAND_UINT4}},
197 /* Record start of catch with the operand's exception index. Push the
198 * current stack depth onto a special catch stack. */
199 {"endCatch", 1, 0, 0, {OPERAND_NONE}},
200 /* End of last catch. Pop the bytecode interpreter's catch stack. */
201 {"pushResult", 1, +1, 0, {OPERAND_NONE}},
202 /* Push the interpreter's object result onto the stack. */
203 {"pushReturnCode", 1, +1, 0, {OPERAND_NONE}},
204 /* Push interpreter's return code (e.g. TCL_OK or TCL_ERROR) as a new
205 * object onto the stack. */
206
207 {"streq", 1, -1, 0, {OPERAND_NONE}},
208 /* Str Equal: push (stknext eq stktop) */
209 {"strneq", 1, -1, 0, {OPERAND_NONE}},
210 /* Str !Equal: push (stknext neq stktop) */
211 {"strcmp", 1, -1, 0, {OPERAND_NONE}},
212 /* Str Compare: push (stknext cmp stktop) */
213 {"strlen", 1, 0, 0, {OPERAND_NONE}},
214 /* Str Length: push (strlen stktop) */
215 {"strindex", 1, -1, 0, {OPERAND_NONE}},
216 /* Str Index: push (strindex stknext stktop) */
217 {"strmatch", 2, -1, 1, {OPERAND_INT1}},
218 /* Str Match: push (strmatch stknext stktop) opnd == nocase */
219
220 {"list", 5, INT_MIN, 1, {OPERAND_UINT4}},
221 /* List: push (stk1 stk2 ... stktop) */
222 {"listIndex", 1, -1, 0, {OPERAND_NONE}},
223 /* List Index: push (listindex stknext stktop) */
224 {"listLength", 1, 0, 0, {OPERAND_NONE}},
225 /* List Len: push (listlength stktop) */
226
227 {"appendScalar1", 2, 0, 1, {OPERAND_LVT1}},
228 /* Append scalar variable at op1<=255 in frame; value is stktop */
229 {"appendScalar4", 5, 0, 1, {OPERAND_LVT4}},
230 /* Append scalar variable at op1 > 255 in frame; value is stktop */
231 {"appendArray1", 2, -1, 1, {OPERAND_LVT1}},
232 /* Append array element; array at op1<=255, value is top then elem */
233 {"appendArray4", 5, -1, 1, {OPERAND_LVT4}},
234 /* Append array element; array at op1>=256, value is top then elem */
235 {"appendArrayStk", 1, -2, 0, {OPERAND_NONE}},
236 /* Append array element; value is stktop, then elem, array names */
237 {"appendStk", 1, -1, 0, {OPERAND_NONE}},
238 /* Append general variable; value is stktop, then unparsed name */
239 {"lappendScalar1", 2, 0, 1, {OPERAND_LVT1}},
240 /* Lappend scalar variable at op1<=255 in frame; value is stktop */
241 {"lappendScalar4", 5, 0, 1, {OPERAND_LVT4}},
242 /* Lappend scalar variable at op1 > 255 in frame; value is stktop */
243 {"lappendArray1", 2, -1, 1, {OPERAND_LVT1}},
244 /* Lappend array element; array at op1<=255, value is top then elem */
245 {"lappendArray4", 5, -1, 1, {OPERAND_LVT4}},
246 /* Lappend array element; array at op1>=256, value is top then elem */
247 {"lappendArrayStk", 1, -2, 0, {OPERAND_NONE}},
248 /* Lappend array element; value is stktop, then elem, array names */
249 {"lappendStk", 1, -1, 0, {OPERAND_NONE}},
250 /* Lappend general variable; value is stktop, then unparsed name */
251
252 {"lindexMulti", 5, INT_MIN, 1, {OPERAND_UINT4}},
253 /* Lindex with generalized args, operand is number of stacked objs
254 * used: (operand-1) entries from stktop are the indices; then list to
255 * process. */
256 {"over", 5, +1, 1, {OPERAND_UINT4}},
257 /* Duplicate the arg-th element from top of stack (TOS=0) */
258 {"lsetList", 1, -2, 0, {OPERAND_NONE}},
259 /* Four-arg version of 'lset'. stktop is old value; next is new
260 * element value, next is the index list; pushes new value */
261 {"lsetFlat", 5, INT_MIN, 1, {OPERAND_UINT4}},
262 /* Three- or >=5-arg version of 'lset', operand is number of stacked
263 * objs: stktop is old value, next is new element value, next come
264 * (operand-2) indices; pushes the new value.
265 */
266
267 {"returnImm", 9, -1, 2, {OPERAND_INT4, OPERAND_UINT4}},
268 /* Compiled [return], code, level are operands; options and result
269 * are on the stack. */
270 {"expon", 1, -1, 0, {OPERAND_NONE}},
271 /* Binary exponentiation operator: push (stknext ** stktop) */
272
273 /*
274 * NOTE: the stack effects of expandStkTop and invokeExpanded are wrong -
275 * but it cannot be done right at compile time, the stack effect is only
276 * known at run time. The value for invokeExpanded is estimated better at
277 * compile time.
278 * See the comments further down in this file, where INST_INVOKE_EXPANDED
279 * is emitted.
280 */
281 {"expandStart", 1, 0, 0, {OPERAND_NONE}},
282 /* Start of command with {*} (expanded) arguments */
283 {"expandStkTop", 5, 0, 1, {OPERAND_UINT4}},
284 /* Expand the list at stacktop: push its elements on the stack */
285 {"invokeExpanded", 1, 0, 0, {OPERAND_NONE}},
286 /* Invoke the command marked by the last 'expandStart' */
287
288 {"listIndexImm", 5, 0, 1, {OPERAND_IDX4}},
289 /* List Index: push (lindex stktop op4) */
290 {"listRangeImm", 9, 0, 2, {OPERAND_IDX4, OPERAND_IDX4}},
291 /* List Range: push (lrange stktop op4 op4) */
292 {"startCommand", 9, 0, 2, {OPERAND_OFFSET4, OPERAND_UINT4}},
293 /* Start of bytecoded command: op is the length of the cmd's code, op2
294 * is number of commands here */
295
296 {"listIn", 1, -1, 0, {OPERAND_NONE}},
297 /* List containment: push [lsearch stktop stknext]>=0) */
298 {"listNotIn", 1, -1, 0, {OPERAND_NONE}},
299 /* List negated containment: push [lsearch stktop stknext]<0) */
300
301 {"pushReturnOpts", 1, +1, 0, {OPERAND_NONE}},
302 /* Push the interpreter's return option dictionary as an object on the
303 * stack. */
304 {"returnStk", 1, -1, 0, {OPERAND_NONE}},
305 /* Compiled [return]; options and result are on the stack, code and
306 * level are in the options. */
307
308 {"dictGet", 5, INT_MIN, 1, {OPERAND_UINT4}},
309 /* The top op4 words (min 1) are a key path into the dictionary just
310 * below the keys on the stack, and all those values are replaced by
311 * the value read out of that key-path (like [dict get]).
312 * Stack: ... dict key1 ... keyN => ... value */
313 {"dictSet", 9, INT_MIN, 2, {OPERAND_UINT4, OPERAND_LVT4}},
314 /* Update a dictionary value such that the keys are a path pointing to
315 * the value. op4#1 = numKeys, op4#2 = LVTindex
316 * Stack: ... key1 ... keyN value => ... newDict */
317 {"dictUnset", 9, INT_MIN, 2, {OPERAND_UINT4, OPERAND_LVT4}},
318 /* Update a dictionary value such that the keys are not a path pointing
319 * to any value. op4#1 = numKeys, op4#2 = LVTindex
320 * Stack: ... key1 ... keyN => ... newDict */
321 {"dictIncrImm", 9, 0, 2, {OPERAND_INT4, OPERAND_LVT4}},
322 /* Update a dictionary value such that the value pointed to by key is
323 * incremented by some value (or set to it if the key isn't in the
324 * dictionary at all). op4#1 = incrAmount, op4#2 = LVTindex
325 * Stack: ... key => ... newDict */
326 {"dictAppend", 5, -1, 1, {OPERAND_LVT4}},
327 /* Update a dictionary value such that the value pointed to by key has
328 * some value string-concatenated onto it. op4 = LVTindex
329 * Stack: ... key valueToAppend => ... newDict */
330 {"dictLappend", 5, -1, 1, {OPERAND_LVT4}},
331 /* Update a dictionary value such that the value pointed to by key has
332 * some value list-appended onto it. op4 = LVTindex
333 * Stack: ... key valueToAppend => ... newDict */
334 {"dictFirst", 5, +2, 1, {OPERAND_LVT4}},
335 /* Begin iterating over the dictionary, using the local scalar
336 * indicated by op4 to hold the iterator state. The local scalar
337 * should not refer to a named variable as the value is not wholly
338 * managed correctly.
339 * Stack: ... dict => ... value key doneBool */
340 {"dictNext", 5, +3, 1, {OPERAND_LVT4}},
341 /* Get the next iteration from the iterator in op4's local scalar.
342 * Stack: ... => ... value key doneBool */
343 {"dictDone", 5, 0, 1, {OPERAND_LVT4}},
344 /* Terminate the iterator in op4's local scalar. Use unsetScalar
345 * instead (with 0 for flags). */
346 {"dictUpdateStart", 9, 0, 2, {OPERAND_LVT4, OPERAND_AUX4}},
347 /* Create the variables (described in the aux data referred to by the
348 * second immediate argument) to mirror the state of the dictionary in
349 * the variable referred to by the first immediate argument. The list
350 * of keys (top of the stack, not popped) must be the same length as
351 * the list of variables.
352 * Stack: ... keyList => ... keyList */
353 {"dictUpdateEnd", 9, -1, 2, {OPERAND_LVT4, OPERAND_AUX4}},
354 /* Reflect the state of local variables (described in the aux data
355 * referred to by the second immediate argument) back to the state of
356 * the dictionary in the variable referred to by the first immediate
357 * argument. The list of keys (popped from the stack) must be the same
358 * length as the list of variables.
359 * Stack: ... keyList => ... */
360 {"jumpTable", 5, -1, 1, {OPERAND_AUX4}},
361 /* Jump according to the jump-table (in AuxData as indicated by the
362 * operand) and the argument popped from the list. Always executes the
363 * next instruction if no match against the table's entries was found.
364 * Stack: ... value => ...
365 * Note that the jump table contains offsets relative to the PC when
366 * it points to this instruction; the code is relocatable. */
367 {"upvar", 5, -1, 1, {OPERAND_LVT4}},
368 /* finds level and otherName in stack, links to local variable at
369 * index op1. Leaves the level on stack. */
370 {"nsupvar", 5, -1, 1, {OPERAND_LVT4}},
371 /* finds namespace and otherName in stack, links to local variable at
372 * index op1. Leaves the namespace on stack. */
373 {"variable", 5, -1, 1, {OPERAND_LVT4}},
374 /* finds namespace and otherName in stack, links to local variable at
375 * index op1. Leaves the namespace on stack. */
376 {"syntax", 9, -1, 2, {OPERAND_INT4, OPERAND_UINT4}},
377 /* Compiled bytecodes to signal syntax error. Equivalent to returnImm
378 * except for the ERR_ALREADY_LOGGED flag in the interpreter. */
379 {"reverse", 5, 0, 1, {OPERAND_UINT4}},
380 /* Reverse the order of the arg elements at the top of stack */
381
382 {"regexp", 2, -1, 1, {OPERAND_INT1}},
383 /* Regexp: push (regexp stknext stktop) opnd == nocase */
384
385 {"existScalar", 5, 1, 1, {OPERAND_LVT4}},
386 /* Test if scalar variable at index op1 in call frame exists */
387 {"existArray", 5, 0, 1, {OPERAND_LVT4}},
388 /* Test if array element exists; array at slot op1, element is
389 * stktop */
390 {"existArrayStk", 1, -1, 0, {OPERAND_NONE}},
391 /* Test if array element exists; element is stktop, array name is
392 * stknext */
393 {"existStk", 1, 0, 0, {OPERAND_NONE}},
394 /* Test if general variable exists; unparsed variable name is stktop*/
395
396 {"nop", 1, 0, 0, {OPERAND_NONE}},
397 /* Do nothing */
398 {"returnCodeBranch", 1, -1, 0, {OPERAND_NONE}},
399 /* Jump to next instruction based on the return code on top of stack
400 * ERROR: +1; RETURN: +3; BREAK: +5; CONTINUE: +7;
401 * Other non-OK: +9
402 */
403
404 {"unsetScalar", 6, 0, 2, {OPERAND_UINT1, OPERAND_LVT4}},
405 /* Make scalar variable at index op2 in call frame cease to exist;
406 * op1 is 1 for errors on problems, 0 otherwise */
407 {"unsetArray", 6, -1, 2, {OPERAND_UINT1, OPERAND_LVT4}},
408 /* Make array element cease to exist; array at slot op2, element is
409 * stktop; op1 is 1 for errors on problems, 0 otherwise */
410 {"unsetArrayStk", 2, -2, 1, {OPERAND_UINT1}},
411 /* Make array element cease to exist; element is stktop, array name is
412 * stknext; op1 is 1 for errors on problems, 0 otherwise */
413 {"unsetStk", 2, -1, 1, {OPERAND_UINT1}},
414 /* Make general variable cease to exist; unparsed variable name is
415 * stktop; op1 is 1 for errors on problems, 0 otherwise */
416
417 {"dictExpand", 1, -1, 0, {OPERAND_NONE}},
418 /* Probe into a dict and extract it (or a subdict of it) into
419 * variables with matched names. Produces list of keys bound as
420 * result. Part of [dict with].
421 * Stack: ... dict path => ... keyList */
422 {"dictRecombineStk", 1, -3, 0, {OPERAND_NONE}},
423 /* Map variable contents back into a dictionary in a variable. Part of
424 * [dict with].
425 * Stack: ... dictVarName path keyList => ... */
426 {"dictRecombineImm", 5, -2, 1, {OPERAND_LVT4}},
427 /* Map variable contents back into a dictionary in the local variable
428 * indicated by the LVT index. Part of [dict with].
429 * Stack: ... path keyList => ... */
430 {"dictExists", 5, INT_MIN, 1, {OPERAND_UINT4}},
431 /* The top op4 words (min 1) are a key path into the dictionary just
432 * below the keys on the stack, and all those values are replaced by a
433 * boolean indicating whether it is possible to read out a value from
434 * that key-path (like [dict exists]).
435 * Stack: ... dict key1 ... keyN => ... boolean */
436 {"verifyDict", 1, -1, 0, {OPERAND_NONE}},
437 /* Verifies that the word on the top of the stack is a dictionary,
438 * popping it if it is and throwing an error if it is not.
439 * Stack: ... value => ... */
440
441 {"strmap", 1, -2, 0, {OPERAND_NONE}},
442 /* Simplified version of [string map] that only applies one change
443 * string, and only case-sensitively.
444 * Stack: ... from to string => ... changedString */
445 {"strfind", 1, -1, 0, {OPERAND_NONE}},
446 /* Find the first index of a needle string in a haystack string,
447 * producing the index (integer) or -1 if nothing found.
448 * Stack: ... needle haystack => ... index */
449 {"strrfind", 1, -1, 0, {OPERAND_NONE}},
450 /* Find the last index of a needle string in a haystack string,
451 * producing the index (integer) or -1 if nothing found.
452 * Stack: ... needle haystack => ... index */
453 {"strrangeImm", 9, 0, 2, {OPERAND_IDX4, OPERAND_IDX4}},
454 /* String Range: push (string range stktop op4 op4) */
455 {"strrange", 1, -2, 0, {OPERAND_NONE}},
456 /* String Range with non-constant arguments.
457 * Stack: ... string idxA idxB => ... substring */
458
459 {"yield", 1, 0, 0, {OPERAND_NONE}},
460 /* Makes the current coroutine yield the value at the top of the
461 * stack, and places the response back on top of the stack when it
462 * resumes.
463 * Stack: ... valueToYield => ... resumeValue */
464 {"coroName", 1, +1, 0, {OPERAND_NONE}},
465 /* Push the name of the interpreter's current coroutine as an object
466 * on the stack. */
467 {"tailcall", 2, INT_MIN, 1, {OPERAND_UINT1}},
468 /* Do a tailcall with the opnd items on the stack as the thing to
469 * tailcall to; opnd must be greater than 0 for the semantics to work
470 * right. */
471
472 {"currentNamespace", 1, +1, 0, {OPERAND_NONE}},
473 /* Push the name of the interpreter's current namespace as an object
474 * on the stack. */
475 {"infoLevelNumber", 1, +1, 0, {OPERAND_NONE}},
476 /* Push the stack depth (i.e., [info level]) of the interpreter as an
477 * object on the stack. */
478 {"infoLevelArgs", 1, 0, 0, {OPERAND_NONE}},
479 /* Push the argument words to a stack depth (i.e., [info level <n>])
480 * of the interpreter as an object on the stack.
481 * Stack: ... depth => ... argList */
482 {"resolveCmd", 1, 0, 0, {OPERAND_NONE}},
483 /* Resolves the command named on the top of the stack to its fully
484 * qualified version, or produces the empty string if no such command
485 * exists. Never generates errors.
486 * Stack: ... cmdName => ... fullCmdName */
487
488 {"tclooSelf", 1, +1, 0, {OPERAND_NONE}},
489 /* Push the identity of the current TclOO object (i.e., the name of
490 * its current public access command) on the stack. */
491 {"tclooClass", 1, 0, 0, {OPERAND_NONE}},
492 /* Push the class of the TclOO object named at the top of the stack
493 * onto the stack.
494 * Stack: ... object => ... class */
495 {"tclooNamespace", 1, 0, 0, {OPERAND_NONE}},
496 /* Push the namespace of the TclOO object named at the top of the
497 * stack onto the stack.
498 * Stack: ... object => ... namespace */
499 {"tclooIsObject", 1, 0, 0, {OPERAND_NONE}},
500 /* Push whether the value named at the top of the stack is a TclOO
501 * object (i.e., a boolean). Can corrupt the interpreter result
502 * despite not throwing, so not safe for use in a post-exception
503 * context.
504 * Stack: ... value => ... boolean */
505
506 {"arrayExistsStk", 1, 0, 0, {OPERAND_NONE}},
507 /* Looks up the element on the top of the stack and tests whether it
508 * is an array. Pushes a boolean describing whether this is the
509 * case. Also runs the whole-array trace on the named variable, so can
510 * throw anything.
511 * Stack: ... varName => ... boolean */
512 {"arrayExistsImm", 5, +1, 1, {OPERAND_LVT4}},
513 /* Looks up the variable indexed by opnd and tests whether it is an
514 * array. Pushes a boolean describing whether this is the case. Also
515 * runs the whole-array trace on the named variable, so can throw
516 * anything.
517 * Stack: ... => ... boolean */
518 {"arrayMakeStk", 1, -1, 0, {OPERAND_NONE}},
519 /* Forces the element on the top of the stack to be the name of an
520 * array.
521 * Stack: ... varName => ... */
522 {"arrayMakeImm", 5, 0, 1, {OPERAND_LVT4}},
523 /* Forces the variable indexed by opnd to be an array. Does not touch
524 * the stack. */
525
526 {"invokeReplace", 6, INT_MIN, 2, {OPERAND_UINT4,OPERAND_UINT1}},
527 /* Invoke command named objv[0], replacing the first two words with
528 * the word at the top of the stack;
529 * <objc,objv> = <op4,top op4 after popping 1> */
530
531 {"listConcat", 1, -1, 0, {OPERAND_NONE}},
532 /* Concatenates the two lists at the top of the stack into a single
533 * list and pushes that resulting list onto the stack.
534 * Stack: ... list1 list2 => ... [lconcat list1 list2] */
535
536 {"expandDrop", 1, 0, 0, {OPERAND_NONE}},
537 /* Drops an element from the auxiliary stack, popping stack elements
538 * until the matching stack depth is reached. */
539
540 /* New foreach implementation */
541 {"foreach_start", 5, +2, 1, {OPERAND_AUX4}},
542 /* Initialize execution of a foreach loop. Operand is aux data index
543 * of the ForeachInfo structure for the foreach command. It pushes 2
544 * elements which hold runtime params for foreach_step, they are later
545 * dropped by foreach_end together with the value lists. NOTE that the
546 * iterator-tracker and info reference must not be passed to bytecodes
547 * that handle normal Tcl values. NOTE that this instruction jumps to
548 * the foreach_step instruction paired with it; the stack info below
549 * is only nominal.
550 * Stack: ... listObjs... => ... listObjs... iterTracker info */
551 {"foreach_step", 1, 0, 0, {OPERAND_NONE}},
552 /* "Step" or begin next iteration of foreach loop. Assigns to foreach
553 * iteration variables. May jump to straight after the foreach_start
554 * that pushed the iterTracker and info values. MUST be followed
555 * immediately by a foreach_end.
556 * Stack: ... listObjs... iterTracker info =>
557 * ... listObjs... iterTracker info */
558 {"foreach_end", 1, 0, 0, {OPERAND_NONE}},
559 /* Clean up a foreach loop by dropping the info value, the tracker
560 * value and the lists that were being iterated over.
561 * Stack: ... listObjs... iterTracker info => ... */
562 {"lmap_collect", 1, -1, 0, {OPERAND_NONE}},
563 /* Appends the value at the top of the stack to the list located on
564 * the stack the "other side" of the foreach-related values.
565 * Stack: ... collector listObjs... iterTracker info value =>
566 * ... collector listObjs... iterTracker info */
567
568 {"strtrim", 1, -1, 0, {OPERAND_NONE}},
569 /* [string trim] core: removes the characters (designated by the value
570 * at the top of the stack) from both ends of the string and pushes
571 * the resulting string.
572 * Stack: ... string charset => ... trimmedString */
573 {"strtrimLeft", 1, -1, 0, {OPERAND_NONE}},
574 /* [string trimleft] core: removes the characters (designated by the
575 * value at the top of the stack) from the left of the string and
576 * pushes the resulting string.
577 * Stack: ... string charset => ... trimmedString */
578 {"strtrimRight", 1, -1, 0, {OPERAND_NONE}},
579 /* [string trimright] core: removes the characters (designated by the
580 * value at the top of the stack) from the right of the string and
581 * pushes the resulting string.
582 * Stack: ... string charset => ... trimmedString */
583
584 {"concatStk", 5, INT_MIN, 1, {OPERAND_UINT4}},
585 /* Wrapper round Tcl_ConcatObj(), used for [concat] and [eval]. opnd
586 * is number of values to concatenate.
587 * Operation: push concat(stk1 stk2 ... stktop) */
588
589 {"strcaseUpper", 1, 0, 0, {OPERAND_NONE}},
590 /* [string toupper] core: converts whole string to upper case using
591 * the default (extended "C" locale) rules.
592 * Stack: ... string => ... newString */
593 {"strcaseLower", 1, 0, 0, {OPERAND_NONE}},
594 /* [string tolower] core: converts whole string to upper case using
595 * the default (extended "C" locale) rules.
596 * Stack: ... string => ... newString */
597 {"strcaseTitle", 1, 0, 0, {OPERAND_NONE}},
598 /* [string totitle] core: converts whole string to upper case using
599 * the default (extended "C" locale) rules.
600 * Stack: ... string => ... newString */
601 {"strreplace", 1, -3, 0, {OPERAND_NONE}},
602 /* [string replace] core: replaces a non-empty range of one string
603 * with the contents of another.
604 * Stack: ... string fromIdx toIdx replacement => ... newString */
605
606 {"originCmd", 1, 0, 0, {OPERAND_NONE}},
607 /* Reports which command was the origin (via namespace import chain)
608 * of the command named on the top of the stack.
609 * Stack: ... cmdName => ... fullOriginalCmdName */
610
611 {"tclooNext", 2, INT_MIN, 1, {OPERAND_UINT1}},
612 /* Call the next item on the TclOO call chain, passing opnd arguments
613 * (min 1, max 255, *includes* "next"). The result of the invoked
614 * method implementation will be pushed on the stack in place of the
615 * arguments (similar to invokeStk).
616 * Stack: ... "next" arg2 arg3 -- argN => ... result */
617 {"tclooNextClass", 2, INT_MIN, 1, {OPERAND_UINT1}},
618 /* Call the following item on the TclOO call chain defined by class
619 * className, passing opnd arguments (min 2, max 255, *includes*
620 * "nextto" and the class name). The result of the invoked method
621 * implementation will be pushed on the stack in place of the
622 * arguments (similar to invokeStk).
623 * Stack: ... "nextto" className arg3 arg4 -- argN => ... result */
624
625 {"yieldToInvoke", 1, 0, 0, {OPERAND_NONE}},
626 /* Makes the current coroutine yield the value at the top of the
627 * stack, invoking the given command/args with resolution in the given
628 * namespace (all packed into a list), and places the list of values
629 * that are the response back on top of the stack when it resumes.
630 * Stack: ... [list ns cmd arg1 ... argN] => ... resumeList */
631
632 {"numericType", 1, 0, 0, {OPERAND_NONE}},
633 /* Pushes the numeric type code of the word at the top of the stack.
634 * Stack: ... value => ... typeCode */
635 {"tryCvtToBoolean", 1, +1, 0, {OPERAND_NONE}},
636 /* Try converting stktop to boolean if possible. No errors.
637 * Stack: ... value => ... value isStrictBool */
638 {"strclass", 2, 0, 1, {OPERAND_SCLS1}},
639 /* See if all the characters of the given string are a member of the
640 * specified (by opnd) character class. Note that an empty string will
641 * satisfy the class check (standard definition of "all").
642 * Stack: ... stringValue => ... boolean */
643
644 {"lappendList", 5, 0, 1, {OPERAND_LVT4}},
645 /* Lappend list to scalar variable at op4 in frame.
646 * Stack: ... list => ... listVarContents */
647 {"lappendListArray", 5, -1, 1, {OPERAND_LVT4}},
648 /* Lappend list to array element; array at op4.
649 * Stack: ... elem list => ... listVarContents */
650 {"lappendListArrayStk", 1, -2, 0, {OPERAND_NONE}},
651 /* Lappend list to array element.
652 * Stack: ... arrayName elem list => ... listVarContents */
653 {"lappendListStk", 1, -1, 0, {OPERAND_NONE}},
654 /* Lappend list to general variable.
655 * Stack: ... varName list => ... listVarContents */
656
657 {"clockRead", 2, +1, 1, {OPERAND_UINT1}},
658 /* Read clock out to the stack. Operand is which clock to read
659 * 0=clicks, 1=microseconds, 2=milliseconds, 3=seconds.
660 * Stack: ... => ... time */
661
662 {NULL, 0, 0, 0, {OPERAND_NONE}}
663 };
664
665 /*
666 * Prototypes for procedures defined later in this file:
667 */
668
669 static ByteCode * CompileSubstObj(Tcl_Interp *interp, Tcl_Obj *objPtr,
670 int flags);
671 static void DupByteCodeInternalRep(Tcl_Obj *srcPtr,
672 Tcl_Obj *copyPtr);
673 static unsigned char * EncodeCmdLocMap(CompileEnv *envPtr,
674 ByteCode *codePtr, unsigned char *startPtr);
675 static void EnterCmdExtentData(CompileEnv *envPtr,
676 int cmdNumber, int numSrcBytes, int numCodeBytes);
677 static void EnterCmdStartData(CompileEnv *envPtr,
678 int cmdNumber, int srcOffset, int codeOffset);
679 static void FreeByteCodeInternalRep(Tcl_Obj *objPtr);
680 static void FreeSubstCodeInternalRep(Tcl_Obj *objPtr);
681 static int GetCmdLocEncodingSize(CompileEnv *envPtr);
682 static int IsCompactibleCompileEnv(Tcl_Interp *interp,
683 CompileEnv *envPtr);
684 #ifdef TCL_COMPILE_STATS
685 static void RecordByteCodeStats(ByteCode *codePtr);
686 #endif /* TCL_COMPILE_STATS */
687 static int SetByteCodeFromAny(Tcl_Interp *interp,
688 Tcl_Obj *objPtr);
689 static void StartExpanding(CompileEnv *envPtr);
690
691 /*
692 * TIP #280: Helper for building the per-word line information of all compiled
693 * commands.
694 */
695 static void EnterCmdWordData(ExtCmdLoc *eclPtr, int srcOffset,
696 Tcl_Token *tokenPtr, const char *cmd, int len,
697 int numWords, int line, int *clNext, int **lines,
698 CompileEnv *envPtr);
699 static void ReleaseCmdWordData(ExtCmdLoc *eclPtr);
700
701 /*
702 * The structure below defines the bytecode Tcl object type by means of
703 * procedures that can be invoked by generic object code.
704 */
705
706 const Tcl_ObjType tclByteCodeType = {
707 "bytecode", /* name */
708 FreeByteCodeInternalRep, /* freeIntRepProc */
709 DupByteCodeInternalRep, /* dupIntRepProc */
710 NULL, /* updateStringProc */
711 SetByteCodeFromAny /* setFromAnyProc */
712 };
713
714 /*
715 * The structure below defines a bytecode Tcl object type to hold the
716 * compiled bytecode for the [subst]itution of Tcl values.
717 */
718
719 static const Tcl_ObjType substCodeType = {
720 "substcode", /* name */
721 FreeSubstCodeInternalRep, /* freeIntRepProc */
722 DupByteCodeInternalRep, /* dupIntRepProc - shared with bytecode */
723 NULL, /* updateStringProc */
724 NULL, /* setFromAnyProc */
725 };
726
727 /*
728 * Helper macros.
729 */
730
731 #define TclIncrUInt4AtPtr(ptr, delta) \
732 TclStoreInt4AtPtr(TclGetUInt4AtPtr(ptr)+(delta), (ptr));
733
734 /*
735 *----------------------------------------------------------------------
736 *
737 * TclSetByteCodeFromAny --
738 *
739 * Part of the bytecode Tcl object type implementation. Attempts to
740 * generate an byte code internal form for the Tcl object "objPtr" by
741 * compiling its string representation. This function also takes a hook
742 * procedure that will be invoked to perform any needed post processing
743 * on the compilation results before generating byte codes. interp is
744 * compilation context and may not be NULL.
745 *
746 * Results:
747 * The return value is a standard Tcl object result. If an error occurs
748 * during compilation, an error message is left in the interpreter's
749 * result.
750 *
751 * Side effects:
752 * Frees the old internal representation. If no error occurs, then the
753 * compiled code is stored as "objPtr"s bytecode representation. Also, if
754 * debugging, initializes the "tcl_traceCompile" Tcl variable used to
755 * trace compilations.
756 *
757 *----------------------------------------------------------------------
758 */
759
760 int
TclSetByteCodeFromAny(Tcl_Interp * interp,Tcl_Obj * objPtr,CompileHookProc * hookProc,ClientData clientData)761 TclSetByteCodeFromAny(
762 Tcl_Interp *interp, /* The interpreter for which the code is being
763 * compiled. Must not be NULL. */
764 Tcl_Obj *objPtr, /* The object to make a ByteCode object. */
765 CompileHookProc *hookProc, /* Procedure to invoke after compilation. */
766 ClientData clientData) /* Hook procedure private data. */
767 {
768 Interp *iPtr = (Interp *) interp;
769 CompileEnv compEnv; /* Compilation environment structure allocated
770 * in frame. */
771 int length, result = TCL_OK;
772 const char *stringPtr;
773 Proc *procPtr = iPtr->compiledProcPtr;
774 ContLineLoc *clLocPtr;
775
776 #ifdef TCL_COMPILE_DEBUG
777 if (!traceInitialized) {
778 if (Tcl_LinkVar(interp, "tcl_traceCompile",
779 (char *) &tclTraceCompile, TCL_LINK_INT) != TCL_OK) {
780 Tcl_Panic("SetByteCodeFromAny: unable to create link for tcl_traceCompile variable");
781 }
782 traceInitialized = 1;
783 }
784 #endif
785
786 stringPtr = TclGetStringFromObj(objPtr, &length);
787
788 /*
789 * TIP #280: Pick up the CmdFrame in which the BC compiler was invoked and
790 * use to initialize the tracking in the compiler. This information was
791 * stored by TclCompEvalObj and ProcCompileProc.
792 */
793
794 TclInitCompileEnv(interp, &compEnv, stringPtr, length,
795 iPtr->invokeCmdFramePtr, iPtr->invokeWord);
796
797 /*
798 * Now we check if we have data about invisible continuation lines for the
799 * script, and make it available to the compile environment, if so.
800 *
801 * It is not clear if the script Tcl_Obj* can be free'd while the compiler
802 * is using it, leading to the release of the associated ContLineLoc
803 * structure as well. To ensure that the latter doesn't happen we set a
804 * lock on it. We release this lock in the function TclFreeCompileEnv(),
805 * found in this file. The "lineCLPtr" hashtable is managed in the file
806 * "tclObj.c".
807 */
808
809 clLocPtr = TclContinuationsGet(objPtr);
810 if (clLocPtr) {
811 compEnv.clNext = &clLocPtr->loc[0];
812 }
813
814 TclCompileScript(interp, stringPtr, length, &compEnv);
815
816 /*
817 * Successful compilation. Add a "done" instruction at the end.
818 */
819
820 TclEmitOpcode(INST_DONE, &compEnv);
821
822 /*
823 * Check for optimizations!
824 *
825 * Test if the generated code is free of most hazards; if so, recompile
826 * but with generation of INST_START_CMD disabled. This produces somewhat
827 * faster code in some cases, and more compact code in more.
828 */
829
830 if (Tcl_GetParent(interp) == NULL &&
831 !Tcl_LimitTypeEnabled(interp, TCL_LIMIT_COMMANDS|TCL_LIMIT_TIME)
832 && IsCompactibleCompileEnv(interp, &compEnv)) {
833 TclFreeCompileEnv(&compEnv);
834 iPtr->compiledProcPtr = procPtr;
835 TclInitCompileEnv(interp, &compEnv, stringPtr, length,
836 iPtr->invokeCmdFramePtr, iPtr->invokeWord);
837 if (clLocPtr) {
838 compEnv.clNext = &clLocPtr->loc[0];
839 }
840 compEnv.atCmdStart = 2; /* The disabling magic. */
841 TclCompileScript(interp, stringPtr, length, &compEnv);
842 assert (compEnv.atCmdStart > 1);
843 TclEmitOpcode(INST_DONE, &compEnv);
844 assert (compEnv.atCmdStart > 1);
845 }
846
847 /*
848 * Apply some peephole optimizations that can cross specific/generic
849 * instruction generator boundaries.
850 */
851
852 if (iPtr->extra.optimizer) {
853 (iPtr->extra.optimizer)(&compEnv);
854 }
855
856 /*
857 * Invoke the compilation hook procedure if one exists.
858 */
859
860 if (hookProc) {
861 result = hookProc(interp, &compEnv, clientData);
862 }
863
864 /*
865 * Change the object into a ByteCode object. Ownership of the literal
866 * objects and aux data items is given to the ByteCode object.
867 */
868
869 #ifdef TCL_COMPILE_DEBUG
870 TclVerifyLocalLiteralTable(&compEnv);
871 #endif /*TCL_COMPILE_DEBUG*/
872
873 if (result == TCL_OK) {
874 TclInitByteCodeObj(objPtr, &compEnv);
875 #ifdef TCL_COMPILE_DEBUG
876 if (tclTraceCompile >= 2) {
877 TclPrintByteCodeObj(interp, objPtr);
878 fflush(stdout);
879 }
880 #endif /* TCL_COMPILE_DEBUG */
881 }
882
883 TclFreeCompileEnv(&compEnv);
884 return result;
885 }
886
887 /*
888 *-----------------------------------------------------------------------
889 *
890 * SetByteCodeFromAny --
891 *
892 * Part of the bytecode Tcl object type implementation. Attempts to
893 * generate an byte code internal form for the Tcl object "objPtr" by
894 * compiling its string representation.
895 *
896 * Results:
897 * The return value is a standard Tcl object result. If an error occurs
898 * during compilation, an error message is left in the interpreter's
899 * result unless "interp" is NULL.
900 *
901 * Side effects:
902 * Frees the old internal representation. If no error occurs, then the
903 * compiled code is stored as "objPtr"s bytecode representation. Also, if
904 * debugging, initializes the "tcl_traceCompile" Tcl variable used to
905 * trace compilations.
906 *
907 *----------------------------------------------------------------------
908 */
909
910 static int
SetByteCodeFromAny(Tcl_Interp * interp,Tcl_Obj * objPtr)911 SetByteCodeFromAny(
912 Tcl_Interp *interp, /* The interpreter for which the code is being
913 * compiled. Must not be NULL. */
914 Tcl_Obj *objPtr) /* The object to make a ByteCode object. */
915 {
916 if (interp == NULL) {
917 return TCL_ERROR;
918 }
919 return TclSetByteCodeFromAny(interp, objPtr, NULL, NULL);
920 }
921
922 /*
923 *----------------------------------------------------------------------
924 *
925 * DupByteCodeInternalRep --
926 *
927 * Part of the bytecode Tcl object type implementation. However, it does
928 * not copy the internal representation of a bytecode Tcl_Obj, but
929 * instead leaves the new object untyped (with a NULL type pointer).
930 * Code will be compiled for the new object only if necessary.
931 *
932 * Results:
933 * None.
934 *
935 * Side effects:
936 * None.
937 *
938 *----------------------------------------------------------------------
939 */
940
941 static void
DupByteCodeInternalRep(Tcl_Obj * srcPtr,Tcl_Obj * copyPtr)942 DupByteCodeInternalRep(
943 Tcl_Obj *srcPtr, /* Object with internal rep to copy. */
944 Tcl_Obj *copyPtr) /* Object with internal rep to set. */
945 {
946 return;
947 }
948
949 /*
950 *----------------------------------------------------------------------
951 *
952 * FreeByteCodeInternalRep --
953 *
954 * Part of the bytecode Tcl object type implementation. Frees the storage
955 * associated with a bytecode object's internal representation unless its
956 * code is actively being executed.
957 *
958 * Results:
959 * None.
960 *
961 * Side effects:
962 * The bytecode object's internal rep is marked invalid and its code gets
963 * freed unless the code is actively being executed. In that case the
964 * cleanup is delayed until the last execution of the code completes.
965 *
966 *----------------------------------------------------------------------
967 */
968
969 static void
FreeByteCodeInternalRep(Tcl_Obj * objPtr)970 FreeByteCodeInternalRep(
971 Tcl_Obj *objPtr) /* Object whose internal rep to free. */
972 {
973 ByteCode *codePtr = objPtr->internalRep.twoPtrValue.ptr1;
974
975 objPtr->typePtr = NULL;
976 if (codePtr->refCount-- <= 1) {
977 TclCleanupByteCode(codePtr);
978 }
979 }
980
981 /*
982 *----------------------------------------------------------------------
983 *
984 * TclCleanupByteCode --
985 *
986 * This procedure does all the real work of freeing up a bytecode
987 * object's ByteCode structure. It's called only when the structure's
988 * reference count becomes zero.
989 *
990 * Results:
991 * None.
992 *
993 * Side effects:
994 * Frees objPtr's bytecode internal representation and sets its type NULL
995 * Also releases its literals and frees its auxiliary data items.
996 *
997 *----------------------------------------------------------------------
998 */
999
1000 void
TclCleanupByteCode(ByteCode * codePtr)1001 TclCleanupByteCode(
1002 ByteCode *codePtr) /* Points to the ByteCode to free. */
1003 {
1004 Tcl_Interp *interp = (Tcl_Interp *) *codePtr->interpHandle;
1005 Interp *iPtr = (Interp *) interp;
1006 int numLitObjects = codePtr->numLitObjects;
1007 int numAuxDataItems = codePtr->numAuxDataItems;
1008 Tcl_Obj **objArrayPtr, *objPtr;
1009 const AuxData *auxDataPtr;
1010 int i;
1011 #ifdef TCL_COMPILE_STATS
1012
1013 if (interp != NULL) {
1014 ByteCodeStats *statsPtr;
1015 Tcl_Time destroyTime;
1016 int lifetimeSec, lifetimeMicroSec, log2;
1017
1018 statsPtr = &iPtr->stats;
1019
1020 statsPtr->numByteCodesFreed++;
1021 statsPtr->currentSrcBytes -= (double) codePtr->numSrcBytes;
1022 statsPtr->currentByteCodeBytes -= (double) codePtr->structureSize;
1023
1024 statsPtr->currentInstBytes -= (double) codePtr->numCodeBytes;
1025 statsPtr->currentLitBytes -= (double)
1026 codePtr->numLitObjects * sizeof(Tcl_Obj *);
1027 statsPtr->currentExceptBytes -= (double)
1028 codePtr->numExceptRanges * sizeof(ExceptionRange);
1029 statsPtr->currentAuxBytes -= (double)
1030 codePtr->numAuxDataItems * sizeof(AuxData);
1031 statsPtr->currentCmdMapBytes -= (double) codePtr->numCmdLocBytes;
1032
1033 Tcl_GetTime(&destroyTime);
1034 lifetimeSec = destroyTime.sec - codePtr->createTime.sec;
1035 if (lifetimeSec > 2000) { /* avoid overflow */
1036 lifetimeSec = 2000;
1037 }
1038 lifetimeMicroSec = 1000000 * lifetimeSec +
1039 (destroyTime.usec - codePtr->createTime.usec);
1040
1041 log2 = TclLog2(lifetimeMicroSec);
1042 if (log2 > 31) {
1043 log2 = 31;
1044 }
1045 statsPtr->lifetimeCount[log2]++;
1046 }
1047 #endif /* TCL_COMPILE_STATS */
1048
1049 /*
1050 * A single heap object holds the ByteCode structure and its code, object,
1051 * command location, and auxiliary data arrays. This means we only need to
1052 * 1) decrement the ref counts of the LiteralEntry's in its literal array,
1053 * 2) call the free procs for the auxiliary data items, 3) free the
1054 * localCache if it is unused, and finally 4) free the ByteCode
1055 * structure's heap object.
1056 *
1057 * The case for TCL_BYTECODE_PRECOMPILED (precompiled ByteCodes, like
1058 * those generated from tbcload) is special, as they doesn't make use of
1059 * the global literal table. They instead maintain private references to
1060 * their literals which must be decremented.
1061 *
1062 * In order to insure a proper and efficient cleanup of the literal array
1063 * when it contains non-shared literals [Bug 983660], we also distinguish
1064 * the case of an interpreter being deleted (signaled by interp == NULL).
1065 * Also, as the interp deletion will remove the global literal table
1066 * anyway, we avoid the extra cost of updating it for each literal being
1067 * released.
1068 */
1069
1070 if (codePtr->flags & TCL_BYTECODE_PRECOMPILED) {
1071
1072 objArrayPtr = codePtr->objArrayPtr;
1073 for (i = 0; i < numLitObjects; i++) {
1074 objPtr = *objArrayPtr;
1075 if (objPtr) {
1076 Tcl_DecrRefCount(objPtr);
1077 }
1078 objArrayPtr++;
1079 }
1080 codePtr->numLitObjects = 0;
1081 } else {
1082 objArrayPtr = codePtr->objArrayPtr;
1083 while (numLitObjects--) {
1084 /* TclReleaseLiteral calls Tcl_DecrRefCount() for us */
1085 TclReleaseLiteral(interp, *objArrayPtr++);
1086 }
1087 }
1088
1089 auxDataPtr = codePtr->auxDataArrayPtr;
1090 for (i = 0; i < numAuxDataItems; i++) {
1091 if (auxDataPtr->type->freeProc != NULL) {
1092 auxDataPtr->type->freeProc(auxDataPtr->clientData);
1093 }
1094 auxDataPtr++;
1095 }
1096
1097 /*
1098 * TIP #280. Release the location data associated with this byte code
1099 * structure, if any. NOTE: The interp we belong to may be gone already,
1100 * and the data with it.
1101 *
1102 * See also tclBasic.c, DeleteInterpProc
1103 */
1104
1105 if (iPtr) {
1106 Tcl_HashEntry *hePtr = Tcl_FindHashEntry(iPtr->lineBCPtr,
1107 (char *) codePtr);
1108
1109 if (hePtr) {
1110 ReleaseCmdWordData(Tcl_GetHashValue(hePtr));
1111 Tcl_DeleteHashEntry(hePtr);
1112 }
1113 }
1114
1115 if (codePtr->localCachePtr && (--codePtr->localCachePtr->refCount == 0)) {
1116 TclFreeLocalCache(interp, codePtr->localCachePtr);
1117 }
1118
1119 TclHandleRelease(codePtr->interpHandle);
1120 ckfree(codePtr);
1121 }
1122
1123 /*
1124 * ---------------------------------------------------------------------
1125 *
1126 * IsCompactibleCompileEnv --
1127 *
1128 * Checks to see if we may apply some basic compaction optimizations to a
1129 * piece of bytecode. Idempotent.
1130 *
1131 * ---------------------------------------------------------------------
1132 */
1133
1134 static int
IsCompactibleCompileEnv(Tcl_Interp * interp,CompileEnv * envPtr)1135 IsCompactibleCompileEnv(
1136 Tcl_Interp *interp,
1137 CompileEnv *envPtr)
1138 {
1139 unsigned char *pc;
1140 int size;
1141
1142 /*
1143 * Special: procedures in the '::tcl' namespace (or its children) are
1144 * considered to be well-behaved and so can have compaction applied even
1145 * if it would otherwise be invalid.
1146 */
1147
1148 if (envPtr->procPtr != NULL && envPtr->procPtr->cmdPtr != NULL
1149 && envPtr->procPtr->cmdPtr->nsPtr != NULL) {
1150 Namespace *nsPtr = envPtr->procPtr->cmdPtr->nsPtr;
1151
1152 if (strcmp(nsPtr->fullName, "::tcl") == 0
1153 || strncmp(nsPtr->fullName, "::tcl::", 7) == 0) {
1154 return 1;
1155 }
1156 }
1157
1158 /*
1159 * Go through and ensure that no operation involved can cause a desired
1160 * change of bytecode sequence during running. This comes down to ensuring
1161 * that there are no mapped variables (due to traces) or calls to external
1162 * commands (traces, [uplevel] trickery). This is actually a very
1163 * conservative check; it turns down a lot of code that is OK in practice.
1164 */
1165
1166 for (pc = envPtr->codeStart ; pc < envPtr->codeNext ; pc += size) {
1167 switch (*pc) {
1168 /* Invokes */
1169 case INST_INVOKE_STK1:
1170 case INST_INVOKE_STK4:
1171 case INST_INVOKE_EXPANDED:
1172 case INST_INVOKE_REPLACE:
1173 return 0;
1174 /* Runtime evals */
1175 case INST_EVAL_STK:
1176 case INST_EXPR_STK:
1177 case INST_YIELD:
1178 return 0;
1179 /* Upvars */
1180 case INST_UPVAR:
1181 case INST_NSUPVAR:
1182 case INST_VARIABLE:
1183 return 0;
1184 default:
1185 size = tclInstructionTable[*pc].numBytes;
1186 assert (size > 0);
1187 break;
1188 }
1189 }
1190
1191 return 1;
1192 }
1193
1194 /*
1195 *----------------------------------------------------------------------
1196 *
1197 * Tcl_SubstObj --
1198 *
1199 * This function performs the substitutions specified on the given string
1200 * as described in the user documentation for the "subst" Tcl command.
1201 *
1202 * Results:
1203 * A Tcl_Obj* containing the substituted string, or NULL to indicate that
1204 * an error occurred.
1205 *
1206 * Side effects:
1207 * See the user documentation.
1208 *
1209 *----------------------------------------------------------------------
1210 */
1211
1212 Tcl_Obj *
Tcl_SubstObj(Tcl_Interp * interp,Tcl_Obj * objPtr,int flags)1213 Tcl_SubstObj(
1214 Tcl_Interp *interp, /* Interpreter in which substitution occurs */
1215 Tcl_Obj *objPtr, /* The value to be substituted. */
1216 int flags) /* What substitutions to do. */
1217 {
1218 NRE_callback *rootPtr = TOP_CB(interp);
1219
1220 if (TclNRRunCallbacks(interp, Tcl_NRSubstObj(interp, objPtr, flags),
1221 rootPtr) != TCL_OK) {
1222 return NULL;
1223 }
1224 return Tcl_GetObjResult(interp);
1225 }
1226
1227 /*
1228 *----------------------------------------------------------------------
1229 *
1230 * Tcl_NRSubstObj --
1231 *
1232 * Request substitution of a Tcl value by the NR stack.
1233 *
1234 * Results:
1235 * Returns TCL_OK.
1236 *
1237 * Side effects:
1238 * Compiles objPtr into bytecode that performs the substitutions as
1239 * governed by flags and places callbacks on the NR stack to execute
1240 * the bytecode and store the result in the interp.
1241 *
1242 *----------------------------------------------------------------------
1243 */
1244
1245 int
Tcl_NRSubstObj(Tcl_Interp * interp,Tcl_Obj * objPtr,int flags)1246 Tcl_NRSubstObj(
1247 Tcl_Interp *interp,
1248 Tcl_Obj *objPtr,
1249 int flags)
1250 {
1251 ByteCode *codePtr = CompileSubstObj(interp, objPtr, flags);
1252
1253 /* TODO: Confirm we do not need this. */
1254 /* Tcl_ResetResult(interp); */
1255 return TclNRExecuteByteCode(interp, codePtr);
1256 }
1257
1258 /*
1259 *----------------------------------------------------------------------
1260 *
1261 * CompileSubstObj --
1262 *
1263 * Compile a Tcl value into ByteCode implementing its substitution, as
1264 * governed by flags.
1265 *
1266 * Results:
1267 * A (ByteCode *) is returned pointing to the resulting ByteCode.
1268 * The caller must manage its refCount and arrange for a call to
1269 * TclCleanupByteCode() when the last reference disappears.
1270 *
1271 * Side effects:
1272 * The Tcl_ObjType of objPtr is changed to the "substcode" type, and the
1273 * ByteCode and governing flags value are kept in the internal rep for
1274 * faster operations the next time CompileSubstObj is called on the same
1275 * value.
1276 *
1277 *----------------------------------------------------------------------
1278 */
1279
1280 static ByteCode *
CompileSubstObj(Tcl_Interp * interp,Tcl_Obj * objPtr,int flags)1281 CompileSubstObj(
1282 Tcl_Interp *interp,
1283 Tcl_Obj *objPtr,
1284 int flags)
1285 {
1286 Interp *iPtr = (Interp *) interp;
1287 ByteCode *codePtr = NULL;
1288
1289 if (objPtr->typePtr == &substCodeType) {
1290 Namespace *nsPtr = iPtr->varFramePtr->nsPtr;
1291
1292 codePtr = objPtr->internalRep.twoPtrValue.ptr1;
1293 if (flags != PTR2INT(objPtr->internalRep.twoPtrValue.ptr2)
1294 || ((Interp *) *codePtr->interpHandle != iPtr)
1295 || (codePtr->compileEpoch != iPtr->compileEpoch)
1296 || (codePtr->nsPtr != nsPtr)
1297 || (codePtr->nsEpoch != nsPtr->resolverEpoch)
1298 || (codePtr->localCachePtr !=
1299 iPtr->varFramePtr->localCachePtr)) {
1300 FreeSubstCodeInternalRep(objPtr);
1301 }
1302 }
1303 if (objPtr->typePtr != &substCodeType) {
1304 CompileEnv compEnv;
1305 int numBytes;
1306 const char *bytes = Tcl_GetStringFromObj(objPtr, &numBytes);
1307
1308 /* TODO: Check for more TIP 280 */
1309 TclInitCompileEnv(interp, &compEnv, bytes, numBytes, NULL, 0);
1310
1311 TclSubstCompile(interp, bytes, numBytes, flags, 1, &compEnv);
1312
1313 TclEmitOpcode(INST_DONE, &compEnv);
1314 TclInitByteCodeObj(objPtr, &compEnv);
1315 objPtr->typePtr = &substCodeType;
1316 TclFreeCompileEnv(&compEnv);
1317
1318 codePtr = objPtr->internalRep.twoPtrValue.ptr1;
1319 objPtr->internalRep.twoPtrValue.ptr1 = codePtr;
1320 objPtr->internalRep.twoPtrValue.ptr2 = INT2PTR(flags);
1321 if (iPtr->varFramePtr->localCachePtr) {
1322 codePtr->localCachePtr = iPtr->varFramePtr->localCachePtr;
1323 codePtr->localCachePtr->refCount++;
1324 }
1325 #ifdef TCL_COMPILE_DEBUG
1326 if (tclTraceCompile >= 2) {
1327 TclPrintByteCodeObj(interp, objPtr);
1328 fflush(stdout);
1329 }
1330 #endif /* TCL_COMPILE_DEBUG */
1331 }
1332 return codePtr;
1333 }
1334
1335 /*
1336 *----------------------------------------------------------------------
1337 *
1338 * FreeSubstCodeInternalRep --
1339 *
1340 * Part of the substcode Tcl object type implementation. Frees the
1341 * storage associated with a substcode object's internal representation
1342 * unless its code is actively being executed.
1343 *
1344 * Results:
1345 * None.
1346 *
1347 * Side effects:
1348 * The substcode object's internal rep is marked invalid and its code
1349 * gets freed unless the code is actively being executed. In that case
1350 * the cleanup is delayed until the last execution of the code completes.
1351 *
1352 *----------------------------------------------------------------------
1353 */
1354
1355 static void
FreeSubstCodeInternalRep(Tcl_Obj * objPtr)1356 FreeSubstCodeInternalRep(
1357 Tcl_Obj *objPtr) /* Object whose internal rep to free. */
1358 {
1359 ByteCode *codePtr = objPtr->internalRep.twoPtrValue.ptr1;
1360
1361 objPtr->typePtr = NULL;
1362 if (codePtr->refCount-- <= 1) {
1363 TclCleanupByteCode(codePtr);
1364 }
1365 }
1366
1367 static void
ReleaseCmdWordData(ExtCmdLoc * eclPtr)1368 ReleaseCmdWordData(
1369 ExtCmdLoc *eclPtr)
1370 {
1371 int i;
1372
1373 if (eclPtr->type == TCL_LOCATION_SOURCE) {
1374 Tcl_DecrRefCount(eclPtr->path);
1375 }
1376 for (i=0 ; i<eclPtr->nuloc ; i++) {
1377 ckfree((char *) eclPtr->loc[i].line);
1378 }
1379
1380 if (eclPtr->loc != NULL) {
1381 ckfree((char *) eclPtr->loc);
1382 }
1383
1384 ckfree((char *) eclPtr);
1385 }
1386
1387 /*
1388 *----------------------------------------------------------------------
1389 *
1390 * TclInitCompileEnv --
1391 *
1392 * Initializes a CompileEnv compilation environment structure for the
1393 * compilation of a string in an interpreter.
1394 *
1395 * Results:
1396 * None.
1397 *
1398 * Side effects:
1399 * The CompileEnv structure is initialized.
1400 *
1401 *----------------------------------------------------------------------
1402 */
1403
1404 void
TclInitCompileEnv(Tcl_Interp * interp,CompileEnv * envPtr,const char * stringPtr,int numBytes,const CmdFrame * invoker,int word)1405 TclInitCompileEnv(
1406 Tcl_Interp *interp, /* The interpreter for which a CompileEnv
1407 * structure is initialized. */
1408 CompileEnv *envPtr,/* Points to the CompileEnv structure to
1409 * initialize. */
1410 const char *stringPtr, /* The source string to be compiled. */
1411 int numBytes, /* Number of bytes in source string. */
1412 const CmdFrame *invoker, /* Location context invoking the bcc */
1413 int word) /* Index of the word in that context getting
1414 * compiled */
1415 {
1416 Interp *iPtr = (Interp *) interp;
1417
1418 assert(tclInstructionTable[LAST_INST_OPCODE+1].name == NULL);
1419
1420 envPtr->iPtr = iPtr;
1421 envPtr->source = stringPtr;
1422 envPtr->numSrcBytes = numBytes;
1423 envPtr->procPtr = iPtr->compiledProcPtr;
1424 iPtr->compiledProcPtr = NULL;
1425 envPtr->numCommands = 0;
1426 envPtr->exceptDepth = 0;
1427 envPtr->maxExceptDepth = 0;
1428 envPtr->maxStackDepth = 0;
1429 envPtr->currStackDepth = 0;
1430 TclInitLiteralTable(&envPtr->localLitTable);
1431
1432 envPtr->codeStart = envPtr->staticCodeSpace;
1433 envPtr->codeNext = envPtr->codeStart;
1434 envPtr->codeEnd = envPtr->codeStart + COMPILEENV_INIT_CODE_BYTES;
1435 envPtr->mallocedCodeArray = 0;
1436
1437 envPtr->literalArrayPtr = envPtr->staticLiteralSpace;
1438 envPtr->literalArrayNext = 0;
1439 envPtr->literalArrayEnd = COMPILEENV_INIT_NUM_OBJECTS;
1440 envPtr->mallocedLiteralArray = 0;
1441
1442 envPtr->exceptArrayPtr = envPtr->staticExceptArraySpace;
1443 envPtr->exceptAuxArrayPtr = envPtr->staticExAuxArraySpace;
1444 envPtr->exceptArrayNext = 0;
1445 envPtr->exceptArrayEnd = COMPILEENV_INIT_EXCEPT_RANGES;
1446 envPtr->mallocedExceptArray = 0;
1447
1448 envPtr->cmdMapPtr = envPtr->staticCmdMapSpace;
1449 envPtr->cmdMapEnd = COMPILEENV_INIT_CMD_MAP_SIZE;
1450 envPtr->mallocedCmdMap = 0;
1451 envPtr->atCmdStart = 1;
1452 envPtr->expandCount = 0;
1453
1454 /*
1455 * TIP #280: Set up the extended command location information, based on
1456 * the context invoking the byte code compiler. This structure is used to
1457 * keep the per-word line information for all compiled commands.
1458 *
1459 * See also tclBasic.c, TclEvalObjEx, for the equivalent code in the
1460 * non-compiling evaluator
1461 */
1462
1463 envPtr->extCmdMapPtr = ckalloc(sizeof(ExtCmdLoc));
1464 envPtr->extCmdMapPtr->loc = NULL;
1465 envPtr->extCmdMapPtr->nloc = 0;
1466 envPtr->extCmdMapPtr->nuloc = 0;
1467 envPtr->extCmdMapPtr->path = NULL;
1468
1469 if (invoker == NULL) {
1470 /*
1471 * Initialize the compiler for relative counting in case of a
1472 * dynamic context.
1473 */
1474
1475 envPtr->line = 1;
1476 if (iPtr->evalFlags & TCL_EVAL_FILE) {
1477 iPtr->evalFlags &= ~TCL_EVAL_FILE;
1478 envPtr->extCmdMapPtr->type = TCL_LOCATION_SOURCE;
1479
1480 if (iPtr->scriptFile) {
1481 /*
1482 * Normalization here, to have the correct pwd. Should have
1483 * negligible impact on performance, as the norm should have
1484 * been done already by the 'source' invoking us, and it
1485 * caches the result.
1486 */
1487
1488 Tcl_Obj *norm =
1489 Tcl_FSGetNormalizedPath(interp, iPtr->scriptFile);
1490
1491 if (norm == NULL) {
1492 /*
1493 * Error message in the interp result. No place to put it.
1494 * And no place to serve the error itself to either. Fake
1495 * a path, empty string.
1496 */
1497
1498 TclNewLiteralStringObj(envPtr->extCmdMapPtr->path, "");
1499 } else {
1500 envPtr->extCmdMapPtr->path = norm;
1501 }
1502 } else {
1503 TclNewLiteralStringObj(envPtr->extCmdMapPtr->path, "");
1504 }
1505
1506 Tcl_IncrRefCount(envPtr->extCmdMapPtr->path);
1507 } else {
1508 envPtr->extCmdMapPtr->type =
1509 (envPtr->procPtr ? TCL_LOCATION_PROC : TCL_LOCATION_BC);
1510 }
1511 } else {
1512 /*
1513 * Initialize the compiler using the context, making counting absolute
1514 * to that context. Note that the context can be byte code execution.
1515 * In that case we have to fill out the missing pieces (line, path,
1516 * ...) which may make change the type as well.
1517 */
1518
1519 CmdFrame *ctxPtr = TclStackAlloc(interp, sizeof(CmdFrame));
1520 int pc = 0;
1521
1522 *ctxPtr = *invoker;
1523 if (invoker->type == TCL_LOCATION_BC) {
1524 /*
1525 * Note: Type BC => ctx.data.eval.path is not used.
1526 * ctx.data.tebc.codePtr is used instead.
1527 */
1528
1529 TclGetSrcInfoForPc(ctxPtr);
1530 pc = 1;
1531 }
1532
1533 if ((ctxPtr->nline <= word) || (ctxPtr->line[word] < 0)) {
1534 /*
1535 * Word is not a literal, relative counting.
1536 */
1537
1538 envPtr->line = 1;
1539 envPtr->extCmdMapPtr->type =
1540 (envPtr->procPtr ? TCL_LOCATION_PROC : TCL_LOCATION_BC);
1541
1542 if (pc && (ctxPtr->type == TCL_LOCATION_SOURCE)) {
1543 /*
1544 * The reference made by 'TclGetSrcInfoForPc' is dead.
1545 */
1546
1547 Tcl_DecrRefCount(ctxPtr->data.eval.path);
1548 }
1549 } else {
1550 envPtr->line = ctxPtr->line[word];
1551 envPtr->extCmdMapPtr->type = ctxPtr->type;
1552
1553 if (ctxPtr->type == TCL_LOCATION_SOURCE) {
1554 envPtr->extCmdMapPtr->path = ctxPtr->data.eval.path;
1555
1556 if (pc) {
1557 /*
1558 * The reference 'TclGetSrcInfoForPc' made is transfered.
1559 */
1560
1561 ctxPtr->data.eval.path = NULL;
1562 } else {
1563 /*
1564 * We have a new reference here.
1565 */
1566
1567 Tcl_IncrRefCount(envPtr->extCmdMapPtr->path);
1568 }
1569 }
1570 }
1571
1572 TclStackFree(interp, ctxPtr);
1573 }
1574
1575 envPtr->extCmdMapPtr->start = envPtr->line;
1576
1577 /*
1578 * Initialize the data about invisible continuation lines as empty, i.e.
1579 * not used. The caller (TclSetByteCodeFromAny) will set this up, if such
1580 * data is available.
1581 */
1582
1583 envPtr->clNext = NULL;
1584
1585 envPtr->auxDataArrayPtr = envPtr->staticAuxDataArraySpace;
1586 envPtr->auxDataArrayNext = 0;
1587 envPtr->auxDataArrayEnd = COMPILEENV_INIT_AUX_DATA_SIZE;
1588 envPtr->mallocedAuxDataArray = 0;
1589 }
1590
1591 /*
1592 *----------------------------------------------------------------------
1593 *
1594 * TclFreeCompileEnv --
1595 *
1596 * Free the storage allocated in a CompileEnv compilation environment
1597 * structure.
1598 *
1599 * Results:
1600 * None.
1601 *
1602 * Side effects:
1603 * Allocated storage in the CompileEnv structure is freed. Note that its
1604 * local literal table is not deleted and its literal objects are not
1605 * released. In addition, storage referenced by its auxiliary data items
1606 * is not freed. This is done so that, when compilation is successful,
1607 * "ownership" of these objects and aux data items is handed over to the
1608 * corresponding ByteCode structure.
1609 *
1610 *----------------------------------------------------------------------
1611 */
1612
1613 void
TclFreeCompileEnv(CompileEnv * envPtr)1614 TclFreeCompileEnv(
1615 CompileEnv *envPtr)/* Points to the CompileEnv structure. */
1616 {
1617 if (envPtr->localLitTable.buckets != envPtr->localLitTable.staticBuckets){
1618 ckfree(envPtr->localLitTable.buckets);
1619 envPtr->localLitTable.buckets = envPtr->localLitTable.staticBuckets;
1620 }
1621 if (envPtr->iPtr) {
1622 /*
1623 * We never converted to Bytecode, so free the things we would
1624 * have transferred to it.
1625 */
1626
1627 int i;
1628 LiteralEntry *entryPtr = envPtr->literalArrayPtr;
1629 AuxData *auxDataPtr = envPtr->auxDataArrayPtr;
1630
1631 for (i = 0; i < envPtr->literalArrayNext; i++) {
1632 TclReleaseLiteral((Tcl_Interp *)envPtr->iPtr, entryPtr->objPtr);
1633 entryPtr++;
1634 }
1635
1636 #ifdef TCL_COMPILE_DEBUG
1637 TclVerifyGlobalLiteralTable(envPtr->iPtr);
1638 #endif /*TCL_COMPILE_DEBUG*/
1639
1640 for (i = 0; i < envPtr->auxDataArrayNext; i++) {
1641 if (auxDataPtr->type->freeProc != NULL) {
1642 auxDataPtr->type->freeProc(auxDataPtr->clientData);
1643 }
1644 auxDataPtr++;
1645 }
1646 }
1647 if (envPtr->mallocedCodeArray) {
1648 ckfree(envPtr->codeStart);
1649 }
1650 if (envPtr->mallocedLiteralArray) {
1651 ckfree(envPtr->literalArrayPtr);
1652 }
1653 if (envPtr->mallocedExceptArray) {
1654 ckfree(envPtr->exceptArrayPtr);
1655 ckfree(envPtr->exceptAuxArrayPtr);
1656 }
1657 if (envPtr->mallocedCmdMap) {
1658 ckfree(envPtr->cmdMapPtr);
1659 }
1660 if (envPtr->mallocedAuxDataArray) {
1661 ckfree(envPtr->auxDataArrayPtr);
1662 }
1663 if (envPtr->extCmdMapPtr) {
1664 ReleaseCmdWordData(envPtr->extCmdMapPtr);
1665 envPtr->extCmdMapPtr = NULL;
1666 }
1667 }
1668
1669 /*
1670 *----------------------------------------------------------------------
1671 *
1672 * TclWordKnownAtCompileTime --
1673 *
1674 * Test whether the value of a token is completely known at compile time.
1675 *
1676 * Results:
1677 * Returns true if the tokenPtr argument points to a word value that is
1678 * completely known at compile time. Generally, values that are known at
1679 * compile time can be compiled to their values, while values that cannot
1680 * be known until substitution at runtime must be compiled to bytecode
1681 * instructions that perform that substitution. For several commands,
1682 * whether or not arguments are known at compile time determine whether
1683 * it is worthwhile to compile at all.
1684 *
1685 * Side effects:
1686 * When returning true, appends the known value of the word to the
1687 * unshared Tcl_Obj (*valuePtr), unless valuePtr is NULL.
1688 *
1689 *----------------------------------------------------------------------
1690 */
1691
1692 int
TclWordKnownAtCompileTime(Tcl_Token * tokenPtr,Tcl_Obj * valuePtr)1693 TclWordKnownAtCompileTime(
1694 Tcl_Token *tokenPtr, /* Points to Tcl_Token we should check */
1695 Tcl_Obj *valuePtr) /* If not NULL, points to an unshared Tcl_Obj
1696 * to which we should append the known value
1697 * of the word. */
1698 {
1699 int numComponents = tokenPtr->numComponents;
1700 Tcl_Obj *tempPtr = NULL;
1701
1702 if (tokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
1703 if (valuePtr != NULL) {
1704 Tcl_AppendToObj(valuePtr, tokenPtr[1].start, tokenPtr[1].size);
1705 }
1706 return 1;
1707 }
1708 if (tokenPtr->type != TCL_TOKEN_WORD) {
1709 return 0;
1710 }
1711 tokenPtr++;
1712 if (valuePtr != NULL) {
1713 tempPtr = Tcl_NewObj();
1714 Tcl_IncrRefCount(tempPtr);
1715 }
1716 while (numComponents--) {
1717 switch (tokenPtr->type) {
1718 case TCL_TOKEN_TEXT:
1719 if (tempPtr != NULL) {
1720 Tcl_AppendToObj(tempPtr, tokenPtr->start, tokenPtr->size);
1721 }
1722 break;
1723
1724 case TCL_TOKEN_BS:
1725 if (tempPtr != NULL) {
1726 char utfBuf[TCL_UTF_MAX] = "";
1727 int length = TclParseBackslash(tokenPtr->start,
1728 tokenPtr->size, NULL, utfBuf);
1729
1730 Tcl_AppendToObj(tempPtr, utfBuf, length);
1731 }
1732 break;
1733
1734 default:
1735 if (tempPtr != NULL) {
1736 Tcl_DecrRefCount(tempPtr);
1737 }
1738 return 0;
1739 }
1740 tokenPtr++;
1741 }
1742 if (valuePtr != NULL) {
1743 Tcl_AppendObjToObj(valuePtr, tempPtr);
1744 Tcl_DecrRefCount(tempPtr);
1745 }
1746 return 1;
1747 }
1748
1749 /*
1750 *----------------------------------------------------------------------
1751 *
1752 * TclCompileScript --
1753 *
1754 * Compile a Tcl script in a string.
1755 *
1756 * Results:
1757 * The return value is TCL_OK on a successful compilation and TCL_ERROR
1758 * on failure. If TCL_ERROR is returned, then the interpreter's result
1759 * contains an error message.
1760 *
1761 * Side effects:
1762 * Adds instructions to envPtr to evaluate the script at runtime.
1763 *
1764 *----------------------------------------------------------------------
1765 */
1766
1767 static int
ExpandRequested(Tcl_Token * tokenPtr,int numWords)1768 ExpandRequested(
1769 Tcl_Token *tokenPtr,
1770 int numWords)
1771 {
1772 /* Determine whether any words of the command require expansion */
1773 while (numWords--) {
1774 if (tokenPtr->type == TCL_TOKEN_EXPAND_WORD) {
1775 return 1;
1776 }
1777 tokenPtr = TokenAfter(tokenPtr);
1778 }
1779 return 0;
1780 }
1781
1782 static void
CompileCmdLiteral(Tcl_Interp * interp,Tcl_Obj * cmdObj,CompileEnv * envPtr)1783 CompileCmdLiteral(
1784 Tcl_Interp *interp,
1785 Tcl_Obj *cmdObj,
1786 CompileEnv *envPtr)
1787 {
1788 int numBytes;
1789 const char *bytes;
1790 Command *cmdPtr;
1791 int cmdLitIdx, extraLiteralFlags = LITERAL_CMD_NAME;
1792
1793 cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, cmdObj);
1794 if ((cmdPtr != NULL) && (cmdPtr->flags & CMD_VIA_RESOLVER)) {
1795 extraLiteralFlags |= LITERAL_UNSHARED;
1796 }
1797
1798 bytes = Tcl_GetStringFromObj(cmdObj, &numBytes);
1799 cmdLitIdx = TclRegisterLiteral(envPtr, (char *)bytes, numBytes, extraLiteralFlags);
1800
1801 if (cmdPtr) {
1802 TclSetCmdNameObj(interp, TclFetchLiteral(envPtr, cmdLitIdx), cmdPtr);
1803 }
1804 TclEmitPush(cmdLitIdx, envPtr);
1805 }
1806
1807 void
TclCompileInvocation(Tcl_Interp * interp,Tcl_Token * tokenPtr,Tcl_Obj * cmdObj,int numWords,CompileEnv * envPtr)1808 TclCompileInvocation(
1809 Tcl_Interp *interp,
1810 Tcl_Token *tokenPtr,
1811 Tcl_Obj *cmdObj,
1812 int numWords,
1813 CompileEnv *envPtr)
1814 {
1815 DefineLineInformation;
1816 int wordIdx = 0, depth = TclGetStackDepth(envPtr);
1817
1818 if (cmdObj) {
1819 CompileCmdLiteral(interp, cmdObj, envPtr);
1820 wordIdx = 1;
1821 tokenPtr = TokenAfter(tokenPtr);
1822 }
1823
1824 for (; wordIdx < numWords; wordIdx++, tokenPtr = TokenAfter(tokenPtr)) {
1825 int objIdx;
1826
1827 SetLineInformation(wordIdx);
1828
1829 if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
1830 CompileTokens(envPtr, tokenPtr, interp);
1831 continue;
1832 }
1833
1834 objIdx = TclRegisterNewLiteral(envPtr,
1835 tokenPtr[1].start, tokenPtr[1].size);
1836 if (envPtr->clNext) {
1837 TclContinuationsEnterDerived(TclFetchLiteral(envPtr, objIdx),
1838 tokenPtr[1].start - envPtr->source, envPtr->clNext);
1839 }
1840 TclEmitPush(objIdx, envPtr);
1841 }
1842
1843 if (wordIdx <= 255) {
1844 TclEmitInvoke(envPtr, INST_INVOKE_STK1, wordIdx);
1845 } else {
1846 TclEmitInvoke(envPtr, INST_INVOKE_STK4, wordIdx);
1847 }
1848 TclCheckStackDepth(depth+1, envPtr);
1849 }
1850
1851 static void
CompileExpanded(Tcl_Interp * interp,Tcl_Token * tokenPtr,Tcl_Obj * cmdObj,int numWords,CompileEnv * envPtr)1852 CompileExpanded(
1853 Tcl_Interp *interp,
1854 Tcl_Token *tokenPtr,
1855 Tcl_Obj *cmdObj,
1856 int numWords,
1857 CompileEnv *envPtr)
1858 {
1859 DefineLineInformation;
1860 int wordIdx = 0;
1861 int depth = TclGetStackDepth(envPtr);
1862
1863 StartExpanding(envPtr);
1864 if (cmdObj) {
1865 CompileCmdLiteral(interp, cmdObj, envPtr);
1866 wordIdx = 1;
1867 tokenPtr = TokenAfter(tokenPtr);
1868 }
1869
1870 for (; wordIdx < numWords; wordIdx++, tokenPtr = TokenAfter(tokenPtr)) {
1871 int objIdx;
1872
1873 SetLineInformation(wordIdx);
1874
1875 if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
1876 CompileTokens(envPtr, tokenPtr, interp);
1877 if (tokenPtr->type == TCL_TOKEN_EXPAND_WORD) {
1878 TclEmitInstInt4(INST_EXPAND_STKTOP,
1879 envPtr->currStackDepth, envPtr);
1880 }
1881 continue;
1882 }
1883
1884 objIdx = TclRegisterNewLiteral(envPtr,
1885 tokenPtr[1].start, tokenPtr[1].size);
1886 if (envPtr->clNext) {
1887 TclContinuationsEnterDerived(TclFetchLiteral(envPtr, objIdx),
1888 tokenPtr[1].start - envPtr->source, envPtr->clNext);
1889 }
1890 TclEmitPush(objIdx, envPtr);
1891 }
1892
1893 /*
1894 * The stack depth during argument expansion can only be managed at
1895 * runtime, as the number of elements in the expanded lists is not known
1896 * at compile time. We adjust here the stack depth estimate so that it is
1897 * correct after the command with expanded arguments returns.
1898 *
1899 * The end effect of this command's invocation is that all the words of
1900 * the command are popped from the stack, and the result is pushed: the
1901 * stack top changes by (1-wordIdx).
1902 *
1903 * Note that the estimates are not correct while the command is being
1904 * prepared and run, INST_EXPAND_STKTOP is not stack-neutral in general.
1905 */
1906
1907 TclEmitInvoke(envPtr, INST_INVOKE_EXPANDED, wordIdx);
1908 TclCheckStackDepth(depth+1, envPtr);
1909 }
1910
1911 static int
CompileCmdCompileProc(Tcl_Interp * interp,Tcl_Parse * parsePtr,Command * cmdPtr,CompileEnv * envPtr)1912 CompileCmdCompileProc(
1913 Tcl_Interp *interp,
1914 Tcl_Parse *parsePtr,
1915 Command *cmdPtr,
1916 CompileEnv *envPtr)
1917 {
1918 DefineLineInformation;
1919 int unwind = 0, incrOffset = -1;
1920 int depth = TclGetStackDepth(envPtr);
1921
1922 /*
1923 * Emit of the INST_START_CMD instruction is controlled by the value of
1924 * envPtr->atCmdStart:
1925 *
1926 * atCmdStart == 2 : We are not using the INST_START_CMD instruction.
1927 * atCmdStart == 1 : INST_START_CMD was the last instruction emitted.
1928 * : We do not need to emit another. Instead we
1929 * : increment the number of cmds started at it (except
1930 * : for the special case at the start of a script.)
1931 * atCmdStart == 0 : The last instruction was something else. We need
1932 * : to emit INST_START_CMD here.
1933 */
1934
1935 switch (envPtr->atCmdStart) {
1936 case 0:
1937 unwind = tclInstructionTable[INST_START_CMD].numBytes;
1938 TclEmitInstInt4(INST_START_CMD, 0, envPtr);
1939 incrOffset = envPtr->codeNext - envPtr->codeStart;
1940 TclEmitInt4(0, envPtr);
1941 break;
1942 case 1:
1943 if (envPtr->codeNext > envPtr->codeStart) {
1944 incrOffset = envPtr->codeNext - 4 - envPtr->codeStart;
1945 }
1946 break;
1947 case 2:
1948 /* Nothing to do */
1949 ;
1950 }
1951
1952 if (TCL_OK == TclAttemptCompileProc(interp, parsePtr, 1, cmdPtr, envPtr)) {
1953 if (incrOffset >= 0) {
1954 /*
1955 * We successfully compiled a command. Increment the number of
1956 * commands that start at the currently active INST_START_CMD.
1957 */
1958
1959 unsigned char *incrPtr = envPtr->codeStart + incrOffset;
1960 unsigned char *startPtr = incrPtr - 5;
1961
1962 TclIncrUInt4AtPtr(incrPtr, 1);
1963 if (unwind) {
1964 /* We started the INST_START_CMD. Record the code length. */
1965 TclStoreInt4AtPtr(envPtr->codeNext - startPtr, startPtr + 1);
1966 }
1967 }
1968 TclCheckStackDepth(depth+1, envPtr);
1969 return TCL_OK;
1970 }
1971
1972 envPtr->codeNext -= unwind; /* Unwind INST_START_CMD */
1973
1974 /*
1975 * Throw out any line information generated by the failed compile attempt.
1976 */
1977
1978 while (mapPtr->nuloc - 1 > eclIndex) {
1979 mapPtr->nuloc--;
1980 ckfree(mapPtr->loc[mapPtr->nuloc].line);
1981 mapPtr->loc[mapPtr->nuloc].line = NULL;
1982 }
1983
1984 /*
1985 * Reset the index of next command. Toss out any from failed nested
1986 * partial compiles.
1987 */
1988
1989 envPtr->numCommands = mapPtr->nuloc;
1990 return TCL_ERROR;
1991 }
1992
1993 static int
CompileCommandTokens(Tcl_Interp * interp,Tcl_Parse * parsePtr,CompileEnv * envPtr)1994 CompileCommandTokens(
1995 Tcl_Interp *interp,
1996 Tcl_Parse *parsePtr,
1997 CompileEnv *envPtr)
1998 {
1999 Interp *iPtr = (Interp *) interp;
2000 Tcl_Token *tokenPtr = parsePtr->tokenPtr;
2001 ExtCmdLoc *eclPtr = envPtr->extCmdMapPtr;
2002 Tcl_Obj *cmdObj = Tcl_NewObj();
2003 Command *cmdPtr = NULL;
2004 int code = TCL_ERROR;
2005 int cmdKnown, expand = -1;
2006 int *wlines, wlineat;
2007 int cmdLine = envPtr->line;
2008 int *clNext = envPtr->clNext;
2009 int cmdIdx = envPtr->numCommands;
2010 int startCodeOffset = envPtr->codeNext - envPtr->codeStart;
2011 int depth = TclGetStackDepth(envPtr);
2012
2013 assert (parsePtr->numWords > 0);
2014
2015 /* Pre-Compile */
2016
2017 envPtr->numCommands++;
2018 EnterCmdStartData(envPtr, cmdIdx,
2019 parsePtr->commandStart - envPtr->source, startCodeOffset);
2020
2021 /*
2022 * TIP #280. Scan the words and compute the extended location information.
2023 * The map first contain full per-word line information for use by the
2024 * compiler. This is later replaced by a reduced form which signals
2025 * non-literal words, stored in 'wlines'.
2026 */
2027
2028 EnterCmdWordData(eclPtr, parsePtr->commandStart - envPtr->source,
2029 parsePtr->tokenPtr, parsePtr->commandStart,
2030 parsePtr->commandSize, parsePtr->numWords, cmdLine,
2031 clNext, &wlines, envPtr);
2032 wlineat = eclPtr->nuloc - 1;
2033
2034 envPtr->line = eclPtr->loc[wlineat].line[0];
2035 envPtr->clNext = eclPtr->loc[wlineat].next[0];
2036
2037 /* Do we know the command word? */
2038 Tcl_IncrRefCount(cmdObj);
2039 tokenPtr = parsePtr->tokenPtr;
2040 cmdKnown = TclWordKnownAtCompileTime(tokenPtr, cmdObj);
2041
2042 /* Is this a command we should (try to) compile with a compileProc ? */
2043 if (cmdKnown && !(iPtr->flags & DONT_COMPILE_CMDS_INLINE)) {
2044 cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, cmdObj);
2045 if (cmdPtr) {
2046 /*
2047 * Found a command. Test the ways we can be told not to attempt
2048 * to compile it.
2049 */
2050 if ((cmdPtr->compileProc == NULL)
2051 || (cmdPtr->nsPtr->flags & NS_SUPPRESS_COMPILATION)
2052 || (cmdPtr->flags & CMD_HAS_EXEC_TRACES)) {
2053 cmdPtr = NULL;
2054 }
2055 }
2056 if (cmdPtr && !(cmdPtr->flags & CMD_COMPILES_EXPANDED)) {
2057 expand = ExpandRequested(parsePtr->tokenPtr, parsePtr->numWords);
2058 if (expand) {
2059 /* We need to expand, but compileProc cannot. */
2060 cmdPtr = NULL;
2061 }
2062 }
2063 }
2064
2065 /* If cmdPtr != NULL, we will try to call cmdPtr->compileProc */
2066 if (cmdPtr) {
2067 code = CompileCmdCompileProc(interp, parsePtr, cmdPtr, envPtr);
2068 }
2069
2070 if (code == TCL_ERROR) {
2071 if (expand < 0) {
2072 expand = ExpandRequested(parsePtr->tokenPtr, parsePtr->numWords);
2073 }
2074
2075 if (expand) {
2076 CompileExpanded(interp, parsePtr->tokenPtr,
2077 cmdKnown ? cmdObj : NULL, parsePtr->numWords, envPtr);
2078 } else {
2079 TclCompileInvocation(interp, parsePtr->tokenPtr,
2080 cmdKnown ? cmdObj : NULL, parsePtr->numWords, envPtr);
2081 }
2082 }
2083
2084 Tcl_DecrRefCount(cmdObj);
2085
2086 TclEmitOpcode(INST_POP, envPtr);
2087 EnterCmdExtentData(envPtr, cmdIdx,
2088 parsePtr->term - parsePtr->commandStart,
2089 (envPtr->codeNext-envPtr->codeStart) - startCodeOffset);
2090
2091 /*
2092 * TIP #280: Free full form of per-word line data and insert the reduced
2093 * form now
2094 */
2095
2096 envPtr->line = cmdLine;
2097 envPtr->clNext = clNext;
2098 ckfree(eclPtr->loc[wlineat].line);
2099 ckfree(eclPtr->loc[wlineat].next);
2100 eclPtr->loc[wlineat].line = wlines;
2101 eclPtr->loc[wlineat].next = NULL;
2102
2103 TclCheckStackDepth(depth, envPtr);
2104 return cmdIdx;
2105 }
2106
2107 void
TclCompileScript(Tcl_Interp * interp,const char * script,int numBytes,CompileEnv * envPtr)2108 TclCompileScript(
2109 Tcl_Interp *interp, /* Used for error and status reporting. Also
2110 * serves as context for finding and compiling
2111 * commands. May not be NULL. */
2112 const char *script, /* The source script to compile. */
2113 int numBytes, /* Number of bytes in script. If < 0, the
2114 * script consists of all bytes up to the
2115 * first null character. */
2116 CompileEnv *envPtr) /* Holds resulting instructions. */
2117 {
2118 int lastCmdIdx = -1; /* Index into envPtr->cmdMapPtr of the last
2119 * command this routine compiles into bytecode.
2120 * Initial value of -1 indicates this routine
2121 * has not yet generated any bytecode. */
2122 const char *p = script; /* Where we are in our compile. */
2123 int depth = TclGetStackDepth(envPtr);
2124 Interp *iPtr = (Interp *) interp;
2125
2126 if (envPtr->iPtr == NULL) {
2127 Tcl_Panic("TclCompileScript() called on uninitialized CompileEnv");
2128 }
2129 /*
2130 * Check depth to avoid overflow of the C execution stack by too many
2131 * nested calls of TclCompileScript (considering interp recursionlimit).
2132 * Factor 5/4 (1.25) is used to avoid too mistaken limit recognition
2133 * during "mixed" evaluation and compilation process (nested eval+compile)
2134 * and is good enough for default recursionlimit (1000).
2135 */
2136 if (iPtr->numLevels / 5 > iPtr->maxNestingDepth / 4) {
2137 Tcl_SetObjResult(interp, Tcl_NewStringObj(
2138 "too many nested compilations (infinite loop?)", -1));
2139 Tcl_SetErrorCode(interp, "TCL", "LIMIT", "STACK", NULL);
2140 TclCompileSyntaxError(interp, envPtr);
2141 return;
2142 }
2143
2144 /* Each iteration compiles one command from the script. */
2145
2146 if (numBytes > 0) {
2147 /*
2148 * Don't use system stack (size of Tcl_Parse is ca. 400 bytes), so
2149 * many nested compilations (body enclosed in body) can cause abnormal
2150 * program termination with a stack overflow exception, bug [fec0c17d39].
2151 */
2152 Tcl_Parse *parsePtr = ckalloc(sizeof(Tcl_Parse));
2153
2154 do {
2155 const char *next;
2156
2157 if (TCL_OK != Tcl_ParseCommand(interp, p, numBytes, 0, parsePtr)) {
2158 /*
2159 * Compile bytecodes to report the parsePtr error at runtime.
2160 */
2161
2162 Tcl_LogCommandInfo(interp, script, parsePtr->commandStart,
2163 parsePtr->term + 1 - parsePtr->commandStart);
2164 TclCompileSyntaxError(interp, envPtr);
2165 ckfree(parsePtr);
2166 return;
2167 }
2168
2169 #ifdef TCL_COMPILE_DEBUG
2170 /*
2171 * If tracing, print a line for each top level command compiled.
2172 * TODO: Suppress when numWords == 0 ?
2173 */
2174
2175 if ((tclTraceCompile >= 1) && (envPtr->procPtr == NULL)) {
2176 int commandLength = parsePtr->term - parsePtr->commandStart;
2177 fprintf(stdout, " Compiling: ");
2178 TclPrintSource(stdout, parsePtr->commandStart,
2179 TclMin(commandLength, 55));
2180 fprintf(stdout, "\n");
2181 }
2182 #endif
2183
2184 /*
2185 * TIP #280: Count newlines before the command start.
2186 * (See test info-30.33).
2187 */
2188
2189 TclAdvanceLines(&envPtr->line, p, parsePtr->commandStart);
2190 TclAdvanceContinuations(&envPtr->line, &envPtr->clNext,
2191 parsePtr->commandStart - envPtr->source);
2192
2193 /*
2194 * Advance parser to the next command in the script.
2195 */
2196
2197 next = parsePtr->commandStart + parsePtr->commandSize;
2198 numBytes -= next - p;
2199 p = next;
2200
2201 if (parsePtr->numWords == 0) {
2202 /*
2203 * The "command" parsed has no words. In this case we can skip
2204 * the rest of the loop body. With no words, clearly
2205 * CompileCommandTokens() has nothing to do. Since the parser
2206 * aggressively sucks up leading comment and white space,
2207 * including newlines, parsePtr->commandStart must be pointing at
2208 * either the end of script, or a command-terminating semi-colon.
2209 * In either case, the TclAdvance*() calls have nothing to do.
2210 * Finally, when no words are parsed, no tokens have been
2211 * allocated at parsePtr->tokenPtr so there's also nothing for
2212 * Tcl_FreeParse() to do.
2213 *
2214 * The advantage of this shortcut is that CompileCommandTokens()
2215 * can be written with an assumption that parsePtr->numWords > 0, with
2216 * the implication the CCT() always generates bytecode.
2217 */
2218 continue;
2219 }
2220
2221 /*
2222 * Avoid stack exhaustion by too many nested calls of TclCompileScript
2223 * (considering interp recursionlimit).
2224 */
2225 iPtr->numLevels++;
2226
2227 lastCmdIdx = CompileCommandTokens(interp, parsePtr, envPtr);
2228
2229 iPtr->numLevels--;
2230
2231 /*
2232 * TIP #280: Track lines in the just compiled command.
2233 */
2234
2235 TclAdvanceLines(&envPtr->line, parsePtr->commandStart, p);
2236 TclAdvanceContinuations(&envPtr->line, &envPtr->clNext,
2237 p - envPtr->source);
2238 Tcl_FreeParse(parsePtr);
2239 } while (numBytes > 0);
2240
2241 ckfree(parsePtr);
2242 }
2243
2244 if (lastCmdIdx == -1) {
2245 /*
2246 * Compiling the script yielded no bytecode. The script must be all
2247 * whitespace, comments, and empty commands. Such scripts are defined
2248 * to successfully produce the empty string result, so we emit the
2249 * simple bytecode that makes that happen.
2250 */
2251
2252 PushStringLiteral(envPtr, "");
2253 } else {
2254 /*
2255 * We compiled at least one command to bytecode. The routine
2256 * CompileCommandTokens() follows the bytecode of each compiled
2257 * command with an INST_POP, so that stack balance is maintained when
2258 * several commands are in sequence. (The result of each command is
2259 * thrown away before moving on to the next command). For the last
2260 * command compiled, we need to undo that INST_POP so that the result
2261 * of the last command becomes the result of the script. The code
2262 * here removes that trailing INST_POP.
2263 */
2264
2265 envPtr->cmdMapPtr[lastCmdIdx].numCodeBytes--;
2266 envPtr->codeNext--;
2267 envPtr->currStackDepth++;
2268 }
2269 TclCheckStackDepth(depth+1, envPtr);
2270 }
2271
2272 /*
2273 *----------------------------------------------------------------------
2274 *
2275 * TclCompileTokens --
2276 *
2277 * Given an array of tokens parsed from a Tcl command (e.g., the tokens
2278 * that make up a word) this procedure emits instructions to evaluate the
2279 * tokens and concatenate their values to form a single result value on
2280 * the interpreter's runtime evaluation stack.
2281 *
2282 * Results:
2283 * The return value is a standard Tcl result. If an error occurs, an
2284 * error message is left in the interpreter's result.
2285 *
2286 * Side effects:
2287 * Instructions are added to envPtr to push and evaluate the tokens at
2288 * runtime.
2289 *
2290 *----------------------------------------------------------------------
2291 */
2292
2293 void
TclCompileVarSubst(Tcl_Interp * interp,Tcl_Token * tokenPtr,CompileEnv * envPtr)2294 TclCompileVarSubst(
2295 Tcl_Interp *interp,
2296 Tcl_Token *tokenPtr,
2297 CompileEnv *envPtr)
2298 {
2299 const char *p, *name = tokenPtr[1].start;
2300 int nameBytes = tokenPtr[1].size;
2301 int i, localVar, localVarName = 1;
2302
2303 /*
2304 * Determine how the variable name should be handled: if it contains any
2305 * namespace qualifiers it is not a local variable (localVarName=-1); if
2306 * it looks like an array element and the token has a single component, it
2307 * should not be created here [Bug 569438] (localVarName=0); otherwise,
2308 * the local variable can safely be created (localVarName=1).
2309 */
2310
2311 for (i = 0, p = name; i < nameBytes; i++, p++) {
2312 if ((*p == ':') && (i < nameBytes-1) && (*(p+1) == ':')) {
2313 localVarName = -1;
2314 break;
2315 } else if ((*p == '(')
2316 && (tokenPtr->numComponents == 1)
2317 && (*(name + nameBytes - 1) == ')')) {
2318 localVarName = 0;
2319 break;
2320 }
2321 }
2322
2323 /*
2324 * Either push the variable's name, or find its index in the array
2325 * of local variables in a procedure frame.
2326 */
2327
2328 localVar = -1;
2329 if (localVarName != -1) {
2330 localVar = TclFindCompiledLocal(name, nameBytes, localVarName, envPtr);
2331 }
2332 if (localVar < 0) {
2333 PushLiteral(envPtr, name, nameBytes);
2334 }
2335
2336 /*
2337 * Emit instructions to load the variable.
2338 */
2339
2340 TclAdvanceLines(&envPtr->line, tokenPtr[1].start,
2341 tokenPtr[1].start + tokenPtr[1].size);
2342
2343 if (tokenPtr->numComponents == 1) {
2344 if (localVar < 0) {
2345 TclEmitOpcode(INST_LOAD_STK, envPtr);
2346 } else if (localVar <= 255) {
2347 TclEmitInstInt1(INST_LOAD_SCALAR1, localVar, envPtr);
2348 } else {
2349 TclEmitInstInt4(INST_LOAD_SCALAR4, localVar, envPtr);
2350 }
2351 } else {
2352 TclCompileTokens(interp, tokenPtr+2, tokenPtr->numComponents-1, envPtr);
2353 if (localVar < 0) {
2354 TclEmitOpcode(INST_LOAD_ARRAY_STK, envPtr);
2355 } else if (localVar <= 255) {
2356 TclEmitInstInt1(INST_LOAD_ARRAY1, localVar, envPtr);
2357 } else {
2358 TclEmitInstInt4(INST_LOAD_ARRAY4, localVar, envPtr);
2359 }
2360 }
2361 }
2362
2363 void
TclCompileTokens(Tcl_Interp * interp,Tcl_Token * tokenPtr,int count,CompileEnv * envPtr)2364 TclCompileTokens(
2365 Tcl_Interp *interp, /* Used for error and status reporting. */
2366 Tcl_Token *tokenPtr, /* Pointer to first in an array of tokens to
2367 * compile. */
2368 int count, /* Number of tokens to consider at tokenPtr.
2369 * Must be at least 1. */
2370 CompileEnv *envPtr) /* Holds the resulting instructions. */
2371 {
2372 Tcl_DString textBuffer; /* Holds concatenated chars from adjacent
2373 * TCL_TOKEN_TEXT, TCL_TOKEN_BS tokens. */
2374 char buffer[TCL_UTF_MAX] = "";
2375 int i, numObjsToConcat, length, adjust;
2376 unsigned char *entryCodeNext = envPtr->codeNext;
2377 #define NUM_STATIC_POS 20
2378 int isLiteral, maxNumCL, numCL;
2379 int *clPosition = NULL;
2380 int depth = TclGetStackDepth(envPtr);
2381
2382 /*
2383 * For the handling of continuation lines in literals we first check if
2384 * this is actually a literal. For if not we can forego the additional
2385 * processing. Otherwise we pre-allocate a small table to store the
2386 * locations of all continuation lines we find in this literal, if any.
2387 * The table is extended if needed.
2388 *
2389 * Note: Different to the equivalent code in function 'TclSubstTokens()'
2390 * (see file "tclParse.c") we do not seem to need the 'adjust' variable.
2391 * We also do not seem to need code which merges continuation line
2392 * information of multiple words which concat'd at runtime. Either that or
2393 * I have not managed to find a test case for these two possibilities yet.
2394 * It might be a difference between compile- versus run-time processing.
2395 */
2396
2397 numCL = 0;
2398 maxNumCL = 0;
2399 isLiteral = 1;
2400 for (i=0 ; i < count; i++) {
2401 if ((tokenPtr[i].type != TCL_TOKEN_TEXT)
2402 && (tokenPtr[i].type != TCL_TOKEN_BS)) {
2403 isLiteral = 0;
2404 break;
2405 }
2406 }
2407
2408 if (isLiteral) {
2409 maxNumCL = NUM_STATIC_POS;
2410 clPosition = ckalloc(maxNumCL * sizeof(int));
2411 }
2412
2413 adjust = 0;
2414 Tcl_DStringInit(&textBuffer);
2415 numObjsToConcat = 0;
2416 for ( ; count > 0; count--, tokenPtr++) {
2417 switch (tokenPtr->type) {
2418 case TCL_TOKEN_TEXT:
2419 TclDStringAppendToken(&textBuffer, tokenPtr);
2420 TclAdvanceLines(&envPtr->line, tokenPtr->start,
2421 tokenPtr->start + tokenPtr->size);
2422 break;
2423
2424 case TCL_TOKEN_BS:
2425 length = TclParseBackslash(tokenPtr->start, tokenPtr->size,
2426 NULL, buffer);
2427 Tcl_DStringAppend(&textBuffer, buffer, length);
2428
2429 /*
2430 * If the backslash sequence we found is in a literal, and
2431 * represented a continuation line, we compute and store its
2432 * location (as char offset to the beginning of the _result_
2433 * script). We may have to extend the table of locations.
2434 *
2435 * Note that the continuation line information is relevant even if
2436 * the word we are processing is not a literal, as it can affect
2437 * nested commands. See the branch for TCL_TOKEN_COMMAND below,
2438 * where the adjustment we are tracking here is taken into
2439 * account. The good thing is that we do not need a table of
2440 * everything, just the number of lines we have to add as
2441 * correction.
2442 */
2443
2444 if ((length == 1) && (buffer[0] == ' ') &&
2445 (tokenPtr->start[1] == '\n')) {
2446 if (isLiteral) {
2447 int clPos = Tcl_DStringLength(&textBuffer);
2448
2449 if (numCL >= maxNumCL) {
2450 maxNumCL *= 2;
2451 clPosition = ckrealloc(clPosition,
2452 maxNumCL * sizeof(int));
2453 }
2454 clPosition[numCL] = clPos;
2455 numCL ++;
2456 }
2457 adjust++;
2458 }
2459 break;
2460
2461 case TCL_TOKEN_COMMAND:
2462 /*
2463 * Push any accumulated chars appearing before the command.
2464 */
2465
2466 if (Tcl_DStringLength(&textBuffer) > 0) {
2467 int literal = TclRegisterDStringLiteral(envPtr, &textBuffer);
2468
2469 TclEmitPush(literal, envPtr);
2470 numObjsToConcat++;
2471 Tcl_DStringFree(&textBuffer);
2472
2473 if (numCL) {
2474 TclContinuationsEnter(TclFetchLiteral(envPtr, literal),
2475 numCL, clPosition);
2476 }
2477 numCL = 0;
2478 }
2479
2480 envPtr->line += adjust;
2481 TclCompileScript(interp, tokenPtr->start+1,
2482 tokenPtr->size-2, envPtr);
2483 envPtr->line -= adjust;
2484 numObjsToConcat++;
2485 break;
2486
2487 case TCL_TOKEN_VARIABLE:
2488 /*
2489 * Push any accumulated chars appearing before the $<var>.
2490 */
2491
2492 if (Tcl_DStringLength(&textBuffer) > 0) {
2493 int literal;
2494
2495 literal = TclRegisterDStringLiteral(envPtr, &textBuffer);
2496 TclEmitPush(literal, envPtr);
2497 numObjsToConcat++;
2498 Tcl_DStringFree(&textBuffer);
2499 }
2500
2501 TclCompileVarSubst(interp, tokenPtr, envPtr);
2502 numObjsToConcat++;
2503 count -= tokenPtr->numComponents;
2504 tokenPtr += tokenPtr->numComponents;
2505 break;
2506
2507 default:
2508 Tcl_Panic("Unexpected token type in TclCompileTokens: %d; %.*s",
2509 tokenPtr->type, tokenPtr->size, tokenPtr->start);
2510 }
2511 }
2512
2513 /*
2514 * Push any accumulated characters appearing at the end.
2515 */
2516
2517 if (Tcl_DStringLength(&textBuffer) > 0) {
2518 int literal = TclRegisterDStringLiteral(envPtr, &textBuffer);
2519
2520 TclEmitPush(literal, envPtr);
2521 numObjsToConcat++;
2522 if (numCL) {
2523 TclContinuationsEnter(TclFetchLiteral(envPtr, literal),
2524 numCL, clPosition);
2525 }
2526 numCL = 0;
2527 }
2528
2529 /*
2530 * If necessary, concatenate the parts of the word.
2531 */
2532
2533 while (numObjsToConcat > 255) {
2534 TclEmitInstInt1(INST_STR_CONCAT1, 255, envPtr);
2535 numObjsToConcat -= 254; /* concat pushes 1 obj, the result */
2536 }
2537 if (numObjsToConcat > 1) {
2538 TclEmitInstInt1(INST_STR_CONCAT1, numObjsToConcat, envPtr);
2539 }
2540
2541 /*
2542 * If the tokens yielded no instructions, push an empty string.
2543 */
2544
2545 if (envPtr->codeNext == entryCodeNext) {
2546 PushStringLiteral(envPtr, "");
2547 }
2548 Tcl_DStringFree(&textBuffer);
2549
2550 /*
2551 * Release the temp table we used to collect the locations of continuation
2552 * lines, if any.
2553 */
2554
2555 if (maxNumCL) {
2556 ckfree(clPosition);
2557 }
2558 TclCheckStackDepth(depth+1, envPtr);
2559 }
2560
2561 /*
2562 *----------------------------------------------------------------------
2563 *
2564 * TclCompileCmdWord --
2565 *
2566 * Given an array of parse tokens for a word containing one or more Tcl
2567 * commands, emit inline instructions to execute them. This procedure
2568 * differs from TclCompileTokens in that a simple word such as a loop
2569 * body enclosed in braces is not just pushed as a string, but is itself
2570 * parsed into tokens and compiled.
2571 *
2572 * Results:
2573 * The return value is a standard Tcl result. If an error occurs, an
2574 * error message is left in the interpreter's result.
2575 *
2576 * Side effects:
2577 * Instructions are added to envPtr to execute the tokens at runtime.
2578 *
2579 *----------------------------------------------------------------------
2580 */
2581
2582 void
TclCompileCmdWord(Tcl_Interp * interp,Tcl_Token * tokenPtr,int count,CompileEnv * envPtr)2583 TclCompileCmdWord(
2584 Tcl_Interp *interp, /* Used for error and status reporting. */
2585 Tcl_Token *tokenPtr, /* Pointer to first in an array of tokens for
2586 * a command word to compile inline. */
2587 int count, /* Number of tokens to consider at tokenPtr.
2588 * Must be at least 1. */
2589 CompileEnv *envPtr) /* Holds the resulting instructions. */
2590 {
2591 if ((count == 1) && (tokenPtr->type == TCL_TOKEN_TEXT)) {
2592 /*
2593 * Handle the common case: if there is a single text token, compile it
2594 * into an inline sequence of instructions.
2595 */
2596
2597 TclCompileScript(interp, tokenPtr->start, tokenPtr->size, envPtr);
2598 } else {
2599 /*
2600 * Multiple tokens or the single token involves substitutions. Emit
2601 * instructions to invoke the eval command procedure at runtime on the
2602 * result of evaluating the tokens.
2603 */
2604
2605 TclCompileTokens(interp, tokenPtr, count, envPtr);
2606 TclEmitInvoke(envPtr, INST_EVAL_STK);
2607 }
2608 }
2609
2610 /*
2611 *----------------------------------------------------------------------
2612 *
2613 * TclCompileExprWords --
2614 *
2615 * Given an array of parse tokens representing one or more words that
2616 * contain a Tcl expression, emit inline instructions to execute the
2617 * expression. This procedure differs from TclCompileExpr in that it
2618 * supports Tcl's two-level substitution semantics for expressions that
2619 * appear as command words.
2620 *
2621 * Results:
2622 * The return value is a standard Tcl result. If an error occurs, an
2623 * error message is left in the interpreter's result.
2624 *
2625 * Side effects:
2626 * Instructions are added to envPtr to execute the expression.
2627 *
2628 *----------------------------------------------------------------------
2629 */
2630
2631 void
TclCompileExprWords(Tcl_Interp * interp,Tcl_Token * tokenPtr,int numWords,CompileEnv * envPtr)2632 TclCompileExprWords(
2633 Tcl_Interp *interp, /* Used for error and status reporting. */
2634 Tcl_Token *tokenPtr, /* Points to first in an array of word tokens
2635 * tokens for the expression to compile
2636 * inline. */
2637 int numWords, /* Number of word tokens starting at tokenPtr.
2638 * Must be at least 1. Each word token
2639 * contains one or more subtokens. */
2640 CompileEnv *envPtr) /* Holds the resulting instructions. */
2641 {
2642 Tcl_Token *wordPtr;
2643 int i, concatItems;
2644
2645 /*
2646 * If the expression is a single word that doesn't require substitutions,
2647 * just compile its string into inline instructions.
2648 */
2649
2650 if ((numWords == 1) && (tokenPtr->type == TCL_TOKEN_SIMPLE_WORD)) {
2651 TclCompileExpr(interp, tokenPtr[1].start,tokenPtr[1].size, envPtr, 1);
2652 return;
2653 }
2654
2655 /*
2656 * Emit code to call the expr command proc at runtime. Concatenate the
2657 * (already substituted once) expr tokens with a space between each.
2658 */
2659
2660 wordPtr = tokenPtr;
2661 for (i = 0; i < numWords; i++) {
2662 CompileTokens(envPtr, wordPtr, interp);
2663 if (i < (numWords - 1)) {
2664 PushStringLiteral(envPtr, " ");
2665 }
2666 wordPtr += wordPtr->numComponents + 1;
2667 }
2668 concatItems = 2*numWords - 1;
2669 while (concatItems > 255) {
2670 TclEmitInstInt1(INST_STR_CONCAT1, 255, envPtr);
2671 concatItems -= 254;
2672 }
2673 if (concatItems > 1) {
2674 TclEmitInstInt1(INST_STR_CONCAT1, concatItems, envPtr);
2675 }
2676 TclEmitOpcode(INST_EXPR_STK, envPtr);
2677 }
2678
2679 /*
2680 *----------------------------------------------------------------------
2681 *
2682 * TclCompileNoOp --
2683 *
2684 * Function called to compile no-op's
2685 *
2686 * Results:
2687 * The return value is TCL_OK, indicating successful compilation.
2688 *
2689 * Side effects:
2690 * Instructions are added to envPtr to execute a no-op at runtime. No
2691 * result is pushed onto the stack: the compiler has to take care of this
2692 * itself if the last compiled command is a NoOp.
2693 *
2694 *----------------------------------------------------------------------
2695 */
2696
2697 int
TclCompileNoOp(Tcl_Interp * interp,Tcl_Parse * parsePtr,Command * cmdPtr,CompileEnv * envPtr)2698 TclCompileNoOp(
2699 Tcl_Interp *interp, /* Used for error reporting. */
2700 Tcl_Parse *parsePtr, /* Points to a parse structure for the command
2701 * created by Tcl_ParseCommand. */
2702 Command *cmdPtr, /* Points to defintion of command being
2703 * compiled. */
2704 CompileEnv *envPtr) /* Holds resulting instructions. */
2705 {
2706 Tcl_Token *tokenPtr;
2707 int i;
2708
2709 tokenPtr = parsePtr->tokenPtr;
2710 for (i = 1; i < parsePtr->numWords; i++) {
2711 tokenPtr = tokenPtr + tokenPtr->numComponents + 1;
2712
2713 if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
2714 CompileTokens(envPtr, tokenPtr, interp);
2715 TclEmitOpcode(INST_POP, envPtr);
2716 }
2717 }
2718 PushStringLiteral(envPtr, "");
2719 return TCL_OK;
2720 }
2721
2722 /*
2723 *----------------------------------------------------------------------
2724 *
2725 * TclInitByteCodeObj --
2726 *
2727 * Create a ByteCode structure and initialize it from a CompileEnv
2728 * compilation environment structure. The ByteCode structure is smaller
2729 * and contains just that information needed to execute the bytecode
2730 * instructions resulting from compiling a Tcl script. The resulting
2731 * structure is placed in the specified object.
2732 *
2733 * Results:
2734 * A newly constructed ByteCode object is stored in the internal
2735 * representation of the objPtr.
2736 *
2737 * Side effects:
2738 * A single heap object is allocated to hold the new ByteCode structure
2739 * and its code, object, command location, and aux data arrays. Note that
2740 * "ownership" (i.e., the pointers to) the Tcl objects and aux data items
2741 * will be handed over to the new ByteCode structure from the CompileEnv
2742 * structure.
2743 *
2744 *----------------------------------------------------------------------
2745 */
2746
2747 void
TclInitByteCodeObj(Tcl_Obj * objPtr,CompileEnv * envPtr)2748 TclInitByteCodeObj(
2749 Tcl_Obj *objPtr, /* Points object that should be initialized,
2750 * and whose string rep contains the source
2751 * code. */
2752 CompileEnv *envPtr)/* Points to the CompileEnv structure from
2753 * which to create a ByteCode structure. */
2754 {
2755 ByteCode *codePtr;
2756 size_t codeBytes, objArrayBytes, exceptArrayBytes, cmdLocBytes;
2757 size_t auxDataArrayBytes, structureSize;
2758 unsigned char *p;
2759 #ifdef TCL_COMPILE_DEBUG
2760 unsigned char *nextPtr;
2761 #endif
2762 int numLitObjects = envPtr->literalArrayNext;
2763 Namespace *namespacePtr;
2764 int i, isNew;
2765 Interp *iPtr;
2766
2767 if (envPtr->iPtr == NULL) {
2768 Tcl_Panic("TclInitByteCodeObj() called on uninitialized CompileEnv");
2769 }
2770
2771 iPtr = envPtr->iPtr;
2772
2773 codeBytes = envPtr->codeNext - envPtr->codeStart;
2774 objArrayBytes = envPtr->literalArrayNext * sizeof(Tcl_Obj *);
2775 exceptArrayBytes = envPtr->exceptArrayNext * sizeof(ExceptionRange);
2776 auxDataArrayBytes = envPtr->auxDataArrayNext * sizeof(AuxData);
2777 cmdLocBytes = GetCmdLocEncodingSize(envPtr);
2778
2779 /*
2780 * Compute the total number of bytes needed for this bytecode.
2781 */
2782
2783 structureSize = sizeof(ByteCode);
2784 structureSize += TCL_ALIGN(codeBytes); /* align object array */
2785 structureSize += TCL_ALIGN(objArrayBytes); /* align exc range arr */
2786 structureSize += TCL_ALIGN(exceptArrayBytes); /* align AuxData array */
2787 structureSize += auxDataArrayBytes;
2788 structureSize += cmdLocBytes;
2789
2790 if (envPtr->iPtr->varFramePtr != NULL) {
2791 namespacePtr = envPtr->iPtr->varFramePtr->nsPtr;
2792 } else {
2793 namespacePtr = envPtr->iPtr->globalNsPtr;
2794 }
2795
2796 p = ckalloc(structureSize);
2797 codePtr = (ByteCode *) p;
2798 codePtr->interpHandle = TclHandlePreserve(iPtr->handle);
2799 codePtr->compileEpoch = iPtr->compileEpoch;
2800 codePtr->nsPtr = namespacePtr;
2801 codePtr->nsEpoch = namespacePtr->resolverEpoch;
2802 codePtr->refCount = 1;
2803 if (namespacePtr->compiledVarResProc || iPtr->resolverPtr) {
2804 codePtr->flags = TCL_BYTECODE_RESOLVE_VARS;
2805 } else {
2806 codePtr->flags = 0;
2807 }
2808 codePtr->source = envPtr->source;
2809 codePtr->procPtr = envPtr->procPtr;
2810
2811 codePtr->numCommands = envPtr->numCommands;
2812 codePtr->numSrcBytes = envPtr->numSrcBytes;
2813 codePtr->numCodeBytes = codeBytes;
2814 codePtr->numLitObjects = numLitObjects;
2815 codePtr->numExceptRanges = envPtr->exceptArrayNext;
2816 codePtr->numAuxDataItems = envPtr->auxDataArrayNext;
2817 codePtr->numCmdLocBytes = cmdLocBytes;
2818 codePtr->maxExceptDepth = envPtr->maxExceptDepth;
2819 codePtr->maxStackDepth = envPtr->maxStackDepth;
2820
2821 p += sizeof(ByteCode);
2822 codePtr->codeStart = p;
2823 memcpy(p, envPtr->codeStart, codeBytes);
2824
2825 p += TCL_ALIGN(codeBytes); /* align object array */
2826 codePtr->objArrayPtr = (Tcl_Obj **) p;
2827 for (i = 0; i < numLitObjects; i++) {
2828 Tcl_Obj *fetched = TclFetchLiteral(envPtr, i);
2829
2830 if (objPtr == fetched) {
2831 /*
2832 * Prevent circular reference where the bytecode internalrep of
2833 * a value contains a literal which is that same value.
2834 * If this is allowed to happen, refcount decrements may not
2835 * reach zero, and memory may leak. Bugs 467523, 3357771
2836 *
2837 * NOTE: [Bugs 3392070, 3389764] We make a copy based completely
2838 * on the string value, and do not call Tcl_DuplicateObj() so we
2839 * can be sure we do not have any lingering cycles hiding in
2840 * the internalrep.
2841 */
2842 int numBytes;
2843 const char *bytes = Tcl_GetStringFromObj(objPtr, &numBytes);
2844
2845 codePtr->objArrayPtr[i] = Tcl_NewStringObj(bytes, numBytes);
2846 Tcl_IncrRefCount(codePtr->objArrayPtr[i]);
2847 TclReleaseLiteral((Tcl_Interp *)iPtr, objPtr);
2848 } else {
2849 codePtr->objArrayPtr[i] = fetched;
2850 }
2851 }
2852
2853 p += TCL_ALIGN(objArrayBytes); /* align exception range array */
2854 if (exceptArrayBytes > 0) {
2855 codePtr->exceptArrayPtr = (ExceptionRange *) p;
2856 memcpy(p, envPtr->exceptArrayPtr, exceptArrayBytes);
2857 } else {
2858 codePtr->exceptArrayPtr = NULL;
2859 }
2860
2861 p += TCL_ALIGN(exceptArrayBytes); /* align AuxData array */
2862 if (auxDataArrayBytes > 0) {
2863 codePtr->auxDataArrayPtr = (AuxData *) p;
2864 memcpy(p, envPtr->auxDataArrayPtr, auxDataArrayBytes);
2865 } else {
2866 codePtr->auxDataArrayPtr = NULL;
2867 }
2868
2869 p += auxDataArrayBytes;
2870 #ifndef TCL_COMPILE_DEBUG
2871 EncodeCmdLocMap(envPtr, codePtr, (unsigned char *) p);
2872 #else
2873 nextPtr = EncodeCmdLocMap(envPtr, codePtr, (unsigned char *) p);
2874 if (((size_t)(nextPtr - p)) != cmdLocBytes) {
2875 Tcl_Panic("TclInitByteCodeObj: encoded cmd location bytes %lu != expected size %lu", (unsigned long)(nextPtr - p), (unsigned long)cmdLocBytes);
2876 }
2877 #endif
2878
2879 /*
2880 * Record various compilation-related statistics about the new ByteCode
2881 * structure. Don't include overhead for statistics-related fields.
2882 */
2883
2884 #ifdef TCL_COMPILE_STATS
2885 codePtr->structureSize = structureSize
2886 - (sizeof(size_t) + sizeof(Tcl_Time));
2887 Tcl_GetTime(&codePtr->createTime);
2888
2889 RecordByteCodeStats(codePtr);
2890 #endif /* TCL_COMPILE_STATS */
2891
2892 /*
2893 * Free the old internal rep then convert the object to a bytecode object
2894 * by making its internal rep point to the just compiled ByteCode.
2895 */
2896
2897 TclFreeIntRep(objPtr);
2898 objPtr->internalRep.twoPtrValue.ptr1 = codePtr;
2899 objPtr->typePtr = &tclByteCodeType;
2900
2901 /*
2902 * TIP #280. Associate the extended per-word line information with the
2903 * byte code object (internal rep), for use with the bc compiler.
2904 */
2905
2906 Tcl_SetHashValue(Tcl_CreateHashEntry(iPtr->lineBCPtr, codePtr,
2907 &isNew), envPtr->extCmdMapPtr);
2908 envPtr->extCmdMapPtr = NULL;
2909
2910 /* We've used up the CompileEnv. Mark as uninitialized. */
2911 envPtr->iPtr = NULL;
2912
2913 codePtr->localCachePtr = NULL;
2914 }
2915
2916 /*
2917 *----------------------------------------------------------------------
2918 *
2919 * TclFindCompiledLocal --
2920 *
2921 * This procedure is called at compile time to look up and optionally
2922 * allocate an entry ("slot") for a variable in a procedure's array of
2923 * local variables. If the variable's name is NULL, a new temporary
2924 * variable is always created. (Such temporary variables can only be
2925 * referenced using their slot index.)
2926 *
2927 * Results:
2928 * If create is 0 and the name is non-NULL, then if the variable is
2929 * found, the index of its entry in the procedure's array of local
2930 * variables is returned; otherwise -1 is returned. If name is NULL, the
2931 * index of a new temporary variable is returned. Finally, if create is 1
2932 * and name is non-NULL, the index of a new entry is returned.
2933 *
2934 * Side effects:
2935 * Creates and registers a new local variable if create is 1 and the
2936 * variable is unknown, or if the name is NULL.
2937 *
2938 *----------------------------------------------------------------------
2939 */
2940
2941 int
TclFindCompiledLocal(const char * name,int nameBytes,int create,CompileEnv * envPtr)2942 TclFindCompiledLocal(
2943 const char *name, /* Points to first character of the name of a
2944 * scalar or array variable. If NULL, a
2945 * temporary var should be created. */
2946 int nameBytes, /* Number of bytes in the name. */
2947 int create, /* If 1, allocate a local frame entry for the
2948 * variable if it is new. */
2949 CompileEnv *envPtr) /* Points to the current compile environment*/
2950 {
2951 CompiledLocal *localPtr;
2952 int localVar = -1;
2953 int i;
2954 Proc *procPtr;
2955
2956 /*
2957 * If not creating a temporary, does a local variable of the specified
2958 * name already exist?
2959 */
2960
2961 procPtr = envPtr->procPtr;
2962
2963 if (procPtr == NULL) {
2964 /*
2965 * Compiling a non-body script: give it read access to the LVT in the
2966 * current localCache
2967 */
2968
2969 LocalCache *cachePtr = envPtr->iPtr->varFramePtr->localCachePtr;
2970 const char *localName;
2971 Tcl_Obj **varNamePtr;
2972 int len;
2973
2974 if (!cachePtr || !name) {
2975 return -1;
2976 }
2977
2978 varNamePtr = &cachePtr->varName0;
2979 for (i=0; i < cachePtr->numVars; varNamePtr++, i++) {
2980 if (*varNamePtr) {
2981 localName = Tcl_GetStringFromObj(*varNamePtr, &len);
2982 if ((len == nameBytes) && !strncmp(name, localName, len)) {
2983 return i;
2984 }
2985 }
2986 }
2987 return -1;
2988 }
2989
2990 if (name != NULL) {
2991 int localCt = procPtr->numCompiledLocals;
2992
2993 localPtr = procPtr->firstLocalPtr;
2994 for (i = 0; i < localCt; i++) {
2995 if (!TclIsVarTemporary(localPtr)) {
2996 char *localName = localPtr->name;
2997
2998 if ((nameBytes == localPtr->nameLength) &&
2999 (strncmp(name, localName, nameBytes) == 0)) {
3000 return i;
3001 }
3002 }
3003 localPtr = localPtr->nextPtr;
3004 }
3005 }
3006
3007 /*
3008 * Create a new variable if appropriate.
3009 */
3010
3011 if (create || (name == NULL)) {
3012 localVar = procPtr->numCompiledLocals;
3013 localPtr = ckalloc(TclOffset(CompiledLocal, name) + nameBytes + 1);
3014 if (procPtr->firstLocalPtr == NULL) {
3015 procPtr->firstLocalPtr = procPtr->lastLocalPtr = localPtr;
3016 } else {
3017 procPtr->lastLocalPtr->nextPtr = localPtr;
3018 procPtr->lastLocalPtr = localPtr;
3019 }
3020 localPtr->nextPtr = NULL;
3021 localPtr->nameLength = nameBytes;
3022 localPtr->frameIndex = localVar;
3023 localPtr->flags = 0;
3024 if (name == NULL) {
3025 localPtr->flags |= VAR_TEMPORARY;
3026 }
3027 localPtr->defValuePtr = NULL;
3028 localPtr->resolveInfo = NULL;
3029
3030 if (name != NULL) {
3031 memcpy(localPtr->name, name, nameBytes);
3032 }
3033 localPtr->name[nameBytes] = '\0';
3034 procPtr->numCompiledLocals++;
3035 }
3036 return localVar;
3037 }
3038
3039 /*
3040 *----------------------------------------------------------------------
3041 *
3042 * TclExpandCodeArray --
3043 *
3044 * Procedure that uses malloc to allocate more storage for a CompileEnv's
3045 * code array.
3046 *
3047 * Results:
3048 * None.
3049 *
3050 * Side effects:
3051 * The byte code array in *envPtr is reallocated to a new array of double
3052 * the size, and if envPtr->mallocedCodeArray is non-zero the old array
3053 * is freed. Byte codes are copied from the old array to the new one.
3054 *
3055 *----------------------------------------------------------------------
3056 */
3057
3058 void
TclExpandCodeArray(void * envArgPtr)3059 TclExpandCodeArray(
3060 void *envArgPtr) /* Points to the CompileEnv whose code array
3061 * must be enlarged. */
3062 {
3063 CompileEnv *envPtr = envArgPtr;
3064 /* The CompileEnv containing the code array to
3065 * be doubled in size. */
3066
3067 /*
3068 * envPtr->codeNext is equal to envPtr->codeEnd. The currently defined
3069 * code bytes are stored between envPtr->codeStart and envPtr->codeNext-1
3070 * [inclusive].
3071 */
3072
3073 size_t currBytes = envPtr->codeNext - envPtr->codeStart;
3074 size_t newBytes = 2 * (envPtr->codeEnd - envPtr->codeStart);
3075
3076 if (envPtr->mallocedCodeArray) {
3077 envPtr->codeStart = ckrealloc(envPtr->codeStart, newBytes);
3078 } else {
3079 /*
3080 * envPtr->codeStart isn't a ckalloc'd pointer, so we must code a
3081 * ckrealloc equivalent for ourselves.
3082 */
3083
3084 unsigned char *newPtr = ckalloc(newBytes);
3085
3086 memcpy(newPtr, envPtr->codeStart, currBytes);
3087 envPtr->codeStart = newPtr;
3088 envPtr->mallocedCodeArray = 1;
3089 }
3090
3091 envPtr->codeNext = envPtr->codeStart + currBytes;
3092 envPtr->codeEnd = envPtr->codeStart + newBytes;
3093 }
3094
3095 /*
3096 *----------------------------------------------------------------------
3097 *
3098 * EnterCmdStartData --
3099 *
3100 * Registers the starting source and bytecode location of a command. This
3101 * information is used at runtime to map between instruction pc and
3102 * source locations.
3103 *
3104 * Results:
3105 * None.
3106 *
3107 * Side effects:
3108 * Inserts source and code location information into the compilation
3109 * environment envPtr for the command at index cmdIndex. The compilation
3110 * environment's CmdLocation array is grown if necessary.
3111 *
3112 *----------------------------------------------------------------------
3113 */
3114
3115 static void
EnterCmdStartData(CompileEnv * envPtr,int cmdIndex,int srcOffset,int codeOffset)3116 EnterCmdStartData(
3117 CompileEnv *envPtr, /* Points to the compilation environment
3118 * structure in which to enter command
3119 * location information. */
3120 int cmdIndex, /* Index of the command whose start data is
3121 * being set. */
3122 int srcOffset, /* Offset of first char of the command. */
3123 int codeOffset) /* Offset of first byte of command code. */
3124 {
3125 CmdLocation *cmdLocPtr;
3126
3127 if ((cmdIndex < 0) || (cmdIndex >= envPtr->numCommands)) {
3128 Tcl_Panic("EnterCmdStartData: bad command index %d", cmdIndex);
3129 }
3130
3131 if (cmdIndex >= envPtr->cmdMapEnd) {
3132 /*
3133 * Expand the command location array by allocating more storage from
3134 * the heap. The currently allocated CmdLocation entries are stored
3135 * from cmdMapPtr[0] up to cmdMapPtr[envPtr->cmdMapEnd] (inclusive).
3136 */
3137
3138 size_t currElems = envPtr->cmdMapEnd;
3139 size_t newElems = 2 * currElems;
3140 size_t currBytes = currElems * sizeof(CmdLocation);
3141 size_t newBytes = newElems * sizeof(CmdLocation);
3142
3143 if (envPtr->mallocedCmdMap) {
3144 envPtr->cmdMapPtr = ckrealloc(envPtr->cmdMapPtr, newBytes);
3145 } else {
3146 /*
3147 * envPtr->cmdMapPtr isn't a ckalloc'd pointer, so we must code a
3148 * ckrealloc equivalent for ourselves.
3149 */
3150
3151 CmdLocation *newPtr = ckalloc(newBytes);
3152
3153 memcpy(newPtr, envPtr->cmdMapPtr, currBytes);
3154 envPtr->cmdMapPtr = newPtr;
3155 envPtr->mallocedCmdMap = 1;
3156 }
3157 envPtr->cmdMapEnd = newElems;
3158 }
3159
3160 if (cmdIndex > 0) {
3161 if (codeOffset < envPtr->cmdMapPtr[cmdIndex-1].codeOffset) {
3162 Tcl_Panic("EnterCmdStartData: cmd map not sorted by code offset");
3163 }
3164 }
3165
3166 cmdLocPtr = &envPtr->cmdMapPtr[cmdIndex];
3167 cmdLocPtr->codeOffset = codeOffset;
3168 cmdLocPtr->srcOffset = srcOffset;
3169 cmdLocPtr->numSrcBytes = -1;
3170 cmdLocPtr->numCodeBytes = -1;
3171 }
3172
3173 /*
3174 *----------------------------------------------------------------------
3175 *
3176 * EnterCmdExtentData --
3177 *
3178 * Registers the source and bytecode length for a command. This
3179 * information is used at runtime to map between instruction pc and
3180 * source locations.
3181 *
3182 * Results:
3183 * None.
3184 *
3185 * Side effects:
3186 * Inserts source and code length information into the compilation
3187 * environment envPtr for the command at index cmdIndex. Starting source
3188 * and bytecode information for the command must already have been
3189 * registered.
3190 *
3191 *----------------------------------------------------------------------
3192 */
3193
3194 static void
EnterCmdExtentData(CompileEnv * envPtr,int cmdIndex,int numSrcBytes,int numCodeBytes)3195 EnterCmdExtentData(
3196 CompileEnv *envPtr, /* Points to the compilation environment
3197 * structure in which to enter command
3198 * location information. */
3199 int cmdIndex, /* Index of the command whose source and code
3200 * length data is being set. */
3201 int numSrcBytes, /* Number of command source chars. */
3202 int numCodeBytes) /* Offset of last byte of command code. */
3203 {
3204 CmdLocation *cmdLocPtr;
3205
3206 if ((cmdIndex < 0) || (cmdIndex >= envPtr->numCommands)) {
3207 Tcl_Panic("EnterCmdExtentData: bad command index %d", cmdIndex);
3208 }
3209
3210 if (cmdIndex > envPtr->cmdMapEnd) {
3211 Tcl_Panic("EnterCmdExtentData: missing start data for command %d",
3212 cmdIndex);
3213 }
3214
3215 cmdLocPtr = &envPtr->cmdMapPtr[cmdIndex];
3216 cmdLocPtr->numSrcBytes = numSrcBytes;
3217 cmdLocPtr->numCodeBytes = numCodeBytes;
3218 }
3219
3220 /*
3221 *----------------------------------------------------------------------
3222 * TIP #280
3223 *
3224 * EnterCmdWordData --
3225 *
3226 * Registers the lines for the words of a command. This information is
3227 * used at runtime by 'info frame'.
3228 *
3229 * Results:
3230 * None.
3231 *
3232 * Side effects:
3233 * Inserts word location information into the compilation environment
3234 * envPtr for the command at index cmdIndex. The compilation
3235 * environment's ExtCmdLoc.ECL array is grown if necessary.
3236 *
3237 *----------------------------------------------------------------------
3238 */
3239
3240 static void
EnterCmdWordData(ExtCmdLoc * eclPtr,int srcOffset,Tcl_Token * tokenPtr,const char * cmd,int len,int numWords,int line,int * clNext,int ** wlines,CompileEnv * envPtr)3241 EnterCmdWordData(
3242 ExtCmdLoc *eclPtr, /* Points to the map environment structure in
3243 * which to enter command location
3244 * information. */
3245 int srcOffset, /* Offset of first char of the command. */
3246 Tcl_Token *tokenPtr,
3247 const char *cmd,
3248 int len,
3249 int numWords,
3250 int line,
3251 int *clNext,
3252 int **wlines,
3253 CompileEnv *envPtr)
3254 {
3255 ECL *ePtr;
3256 const char *last;
3257 int wordIdx, wordLine, *wwlines, *wordNext;
3258
3259 if (eclPtr->nuloc >= eclPtr->nloc) {
3260 /*
3261 * Expand the ECL array by allocating more storage from the heap. The
3262 * currently allocated ECL entries are stored from eclPtr->loc[0] up
3263 * to eclPtr->loc[eclPtr->nuloc-1] (inclusive).
3264 */
3265
3266 size_t currElems = eclPtr->nloc;
3267 size_t newElems = (currElems ? 2*currElems : 1);
3268 size_t newBytes = newElems * sizeof(ECL);
3269
3270 eclPtr->loc = ckrealloc(eclPtr->loc, newBytes);
3271 eclPtr->nloc = newElems;
3272 }
3273
3274 ePtr = &eclPtr->loc[eclPtr->nuloc];
3275 ePtr->srcOffset = srcOffset;
3276 ePtr->line = ckalloc(numWords * sizeof(int));
3277 ePtr->next = ckalloc(numWords * sizeof(int *));
3278 ePtr->nline = numWords;
3279 wwlines = ckalloc(numWords * sizeof(int));
3280
3281 last = cmd;
3282 wordLine = line;
3283 wordNext = clNext;
3284 for (wordIdx=0 ; wordIdx<numWords;
3285 wordIdx++, tokenPtr += tokenPtr->numComponents + 1) {
3286 TclAdvanceLines(&wordLine, last, tokenPtr->start);
3287 TclAdvanceContinuations(&wordLine, &wordNext,
3288 tokenPtr->start - envPtr->source);
3289 /* See Ticket 4b61afd660 */
3290 wwlines[wordIdx] =
3291 ((wordIdx == 0) || TclWordKnownAtCompileTime(tokenPtr, NULL))
3292 ? wordLine : -1;
3293 ePtr->line[wordIdx] = wordLine;
3294 ePtr->next[wordIdx] = wordNext;
3295 last = tokenPtr->start;
3296 }
3297
3298 *wlines = wwlines;
3299 eclPtr->nuloc ++;
3300 }
3301
3302 /*
3303 *----------------------------------------------------------------------
3304 *
3305 * TclCreateExceptRange --
3306 *
3307 * Procedure that allocates and initializes a new ExceptionRange
3308 * structure of the specified kind in a CompileEnv.
3309 *
3310 * Results:
3311 * Returns the index for the newly created ExceptionRange.
3312 *
3313 * Side effects:
3314 * If there is not enough room in the CompileEnv's ExceptionRange array,
3315 * the array in expanded: a new array of double the size is allocated, if
3316 * envPtr->mallocedExceptArray is non-zero the old array is freed, and
3317 * ExceptionRange entries are copied from the old array to the new one.
3318 *
3319 *----------------------------------------------------------------------
3320 */
3321
3322 int
TclCreateExceptRange(ExceptionRangeType type,CompileEnv * envPtr)3323 TclCreateExceptRange(
3324 ExceptionRangeType type, /* The kind of ExceptionRange desired. */
3325 CompileEnv *envPtr)/* Points to CompileEnv for which to create a
3326 * new ExceptionRange structure. */
3327 {
3328 ExceptionRange *rangePtr;
3329 ExceptionAux *auxPtr;
3330 int index = envPtr->exceptArrayNext;
3331
3332 if (index >= envPtr->exceptArrayEnd) {
3333 /*
3334 * Expand the ExceptionRange array. The currently allocated entries
3335 * are stored between elements 0 and (envPtr->exceptArrayNext - 1)
3336 * [inclusive].
3337 */
3338
3339 size_t currBytes =
3340 envPtr->exceptArrayNext * sizeof(ExceptionRange);
3341 size_t currBytes2 = envPtr->exceptArrayNext * sizeof(ExceptionAux);
3342 int newElems = 2*envPtr->exceptArrayEnd;
3343 size_t newBytes = newElems * sizeof(ExceptionRange);
3344 size_t newBytes2 = newElems * sizeof(ExceptionAux);
3345
3346 if (envPtr->mallocedExceptArray) {
3347 envPtr->exceptArrayPtr =
3348 ckrealloc(envPtr->exceptArrayPtr, newBytes);
3349 envPtr->exceptAuxArrayPtr =
3350 ckrealloc(envPtr->exceptAuxArrayPtr, newBytes2);
3351 } else {
3352 /*
3353 * envPtr->exceptArrayPtr isn't a ckalloc'd pointer, so we must
3354 * code a ckrealloc equivalent for ourselves.
3355 */
3356
3357 ExceptionRange *newPtr = ckalloc(newBytes);
3358 ExceptionAux *newPtr2 = ckalloc(newBytes2);
3359
3360 memcpy(newPtr, envPtr->exceptArrayPtr, currBytes);
3361 memcpy(newPtr2, envPtr->exceptAuxArrayPtr, currBytes2);
3362 envPtr->exceptArrayPtr = newPtr;
3363 envPtr->exceptAuxArrayPtr = newPtr2;
3364 envPtr->mallocedExceptArray = 1;
3365 }
3366 envPtr->exceptArrayEnd = newElems;
3367 }
3368 envPtr->exceptArrayNext++;
3369
3370 rangePtr = &envPtr->exceptArrayPtr[index];
3371 rangePtr->type = type;
3372 rangePtr->nestingLevel = envPtr->exceptDepth;
3373 rangePtr->codeOffset = -1;
3374 rangePtr->numCodeBytes = -1;
3375 rangePtr->breakOffset = -1;
3376 rangePtr->continueOffset = -1;
3377 rangePtr->catchOffset = -1;
3378 auxPtr = &envPtr->exceptAuxArrayPtr[index];
3379 auxPtr->supportsContinue = 1;
3380 auxPtr->stackDepth = envPtr->currStackDepth;
3381 auxPtr->expandTarget = envPtr->expandCount;
3382 auxPtr->expandTargetDepth = -1;
3383 auxPtr->numBreakTargets = 0;
3384 auxPtr->breakTargets = NULL;
3385 auxPtr->allocBreakTargets = 0;
3386 auxPtr->numContinueTargets = 0;
3387 auxPtr->continueTargets = NULL;
3388 auxPtr->allocContinueTargets = 0;
3389 return index;
3390 }
3391
3392 /*
3393 * ---------------------------------------------------------------------
3394 *
3395 * TclGetInnermostExceptionRange --
3396 *
3397 * Returns the innermost exception range that covers the current code
3398 * creation point, and (optionally) the stack depth that is expected at
3399 * that point. Relies on the fact that the range has a numCodeBytes = -1
3400 * when it is being populated and that inner ranges come after outer
3401 * ranges.
3402 *
3403 * ---------------------------------------------------------------------
3404 */
3405
3406 ExceptionRange *
TclGetInnermostExceptionRange(CompileEnv * envPtr,int returnCode,ExceptionAux ** auxPtrPtr)3407 TclGetInnermostExceptionRange(
3408 CompileEnv *envPtr,
3409 int returnCode,
3410 ExceptionAux **auxPtrPtr)
3411 {
3412 int i = envPtr->exceptArrayNext;
3413 ExceptionRange *rangePtr = envPtr->exceptArrayPtr + i;
3414
3415 while (i > 0) {
3416 rangePtr--; i--;
3417
3418 if (CurrentOffset(envPtr) >= rangePtr->codeOffset &&
3419 (rangePtr->numCodeBytes == -1 || CurrentOffset(envPtr) <
3420 rangePtr->codeOffset+rangePtr->numCodeBytes) &&
3421 (returnCode != TCL_CONTINUE ||
3422 envPtr->exceptAuxArrayPtr[i].supportsContinue)) {
3423
3424 if (auxPtrPtr) {
3425 *auxPtrPtr = envPtr->exceptAuxArrayPtr + i;
3426 }
3427 return rangePtr;
3428 }
3429 }
3430 return NULL;
3431 }
3432
3433 /*
3434 * ---------------------------------------------------------------------
3435 *
3436 * TclAddLoopBreakFixup, TclAddLoopContinueFixup --
3437 *
3438 * Adds a place that wants to break/continue to the loop exception range
3439 * tracking that will be fixed up once the loop can be finalized. These
3440 * functions will generate an INST_JUMP4 that will be fixed up during the
3441 * loop finalization.
3442 *
3443 * ---------------------------------------------------------------------
3444 */
3445
3446 void
TclAddLoopBreakFixup(CompileEnv * envPtr,ExceptionAux * auxPtr)3447 TclAddLoopBreakFixup(
3448 CompileEnv *envPtr,
3449 ExceptionAux *auxPtr)
3450 {
3451 int range = auxPtr - envPtr->exceptAuxArrayPtr;
3452
3453 if (envPtr->exceptArrayPtr[range].type != LOOP_EXCEPTION_RANGE) {
3454 Tcl_Panic("trying to add 'break' fixup to full exception range");
3455 }
3456
3457 if (++auxPtr->numBreakTargets > auxPtr->allocBreakTargets) {
3458 auxPtr->allocBreakTargets *= 2;
3459 auxPtr->allocBreakTargets += 2;
3460 if (auxPtr->breakTargets) {
3461 auxPtr->breakTargets = ckrealloc(auxPtr->breakTargets,
3462 sizeof(int) * auxPtr->allocBreakTargets);
3463 } else {
3464 auxPtr->breakTargets =
3465 ckalloc(sizeof(int) * auxPtr->allocBreakTargets);
3466 }
3467 }
3468 auxPtr->breakTargets[auxPtr->numBreakTargets - 1] = CurrentOffset(envPtr);
3469 TclEmitInstInt4(INST_JUMP4, 0, envPtr);
3470 }
3471
3472 void
TclAddLoopContinueFixup(CompileEnv * envPtr,ExceptionAux * auxPtr)3473 TclAddLoopContinueFixup(
3474 CompileEnv *envPtr,
3475 ExceptionAux *auxPtr)
3476 {
3477 int range = auxPtr - envPtr->exceptAuxArrayPtr;
3478
3479 if (envPtr->exceptArrayPtr[range].type != LOOP_EXCEPTION_RANGE) {
3480 Tcl_Panic("trying to add 'continue' fixup to full exception range");
3481 }
3482
3483 if (++auxPtr->numContinueTargets > auxPtr->allocContinueTargets) {
3484 auxPtr->allocContinueTargets *= 2;
3485 auxPtr->allocContinueTargets += 2;
3486 if (auxPtr->continueTargets) {
3487 auxPtr->continueTargets = ckrealloc(auxPtr->continueTargets,
3488 sizeof(int) * auxPtr->allocContinueTargets);
3489 } else {
3490 auxPtr->continueTargets =
3491 ckalloc(sizeof(int) * auxPtr->allocContinueTargets);
3492 }
3493 }
3494 auxPtr->continueTargets[auxPtr->numContinueTargets - 1] =
3495 CurrentOffset(envPtr);
3496 TclEmitInstInt4(INST_JUMP4, 0, envPtr);
3497 }
3498
3499 /*
3500 * ---------------------------------------------------------------------
3501 *
3502 * TclCleanupStackForBreakContinue --
3503 *
3504 * Ditch the extra elements from the auxiliary stack and the main stack.
3505 * How to do this exactly depends on whether there are any elements on
3506 * the auxiliary stack to pop.
3507 *
3508 * ---------------------------------------------------------------------
3509 */
3510
3511 void
TclCleanupStackForBreakContinue(CompileEnv * envPtr,ExceptionAux * auxPtr)3512 TclCleanupStackForBreakContinue(
3513 CompileEnv *envPtr,
3514 ExceptionAux *auxPtr)
3515 {
3516 int savedStackDepth = envPtr->currStackDepth;
3517 int toPop = envPtr->expandCount - auxPtr->expandTarget;
3518
3519 if (toPop > 0) {
3520 while (toPop --> 0) {
3521 TclEmitOpcode(INST_EXPAND_DROP, envPtr);
3522 }
3523 TclAdjustStackDepth(auxPtr->expandTargetDepth - envPtr->currStackDepth,
3524 envPtr);
3525 envPtr->currStackDepth = auxPtr->expandTargetDepth;
3526 }
3527 toPop = envPtr->currStackDepth - auxPtr->stackDepth;
3528 while (toPop --> 0) {
3529 TclEmitOpcode(INST_POP, envPtr);
3530 }
3531 envPtr->currStackDepth = savedStackDepth;
3532 }
3533
3534 /*
3535 * ---------------------------------------------------------------------
3536 *
3537 * StartExpanding --
3538 *
3539 * Pushes an INST_EXPAND_START and does some additional housekeeping so
3540 * that the [break] and [continue] compilers can use an exception-free
3541 * issue to discard it.
3542 *
3543 * ---------------------------------------------------------------------
3544 */
3545
3546 static void
StartExpanding(CompileEnv * envPtr)3547 StartExpanding(
3548 CompileEnv *envPtr)
3549 {
3550 int i;
3551
3552 TclEmitOpcode(INST_EXPAND_START, envPtr);
3553
3554 /*
3555 * Update inner exception ranges with information about the environment
3556 * where this expansion started.
3557 */
3558
3559 for (i=0 ; i<envPtr->exceptArrayNext ; i++) {
3560 ExceptionRange *rangePtr = &envPtr->exceptArrayPtr[i];
3561 ExceptionAux *auxPtr = &envPtr->exceptAuxArrayPtr[i];
3562
3563 /*
3564 * Ignore loops unless they're still being built.
3565 */
3566
3567 if (rangePtr->codeOffset > CurrentOffset(envPtr)) {
3568 continue;
3569 }
3570 if (rangePtr->numCodeBytes != -1) {
3571 continue;
3572 }
3573
3574 /*
3575 * Adequate condition: further out loops and further in exceptions
3576 * don't actually need this information.
3577 */
3578
3579 if (auxPtr->expandTarget == envPtr->expandCount) {
3580 auxPtr->expandTargetDepth = envPtr->currStackDepth;
3581 }
3582 }
3583
3584 /*
3585 * There's now one more expansion being processed on the auxiliary stack.
3586 */
3587
3588 envPtr->expandCount++;
3589 }
3590
3591 /*
3592 * ---------------------------------------------------------------------
3593 *
3594 * TclFinalizeLoopExceptionRange --
3595 *
3596 * Finalizes a loop exception range, binding the registered [break] and
3597 * [continue] implementations so that they jump to the correct place.
3598 * Note that this must only be called after *all* the exception range
3599 * target offsets have been set.
3600 *
3601 * ---------------------------------------------------------------------
3602 */
3603
3604 void
TclFinalizeLoopExceptionRange(CompileEnv * envPtr,int range)3605 TclFinalizeLoopExceptionRange(
3606 CompileEnv *envPtr,
3607 int range)
3608 {
3609 ExceptionRange *rangePtr = &envPtr->exceptArrayPtr[range];
3610 ExceptionAux *auxPtr = &envPtr->exceptAuxArrayPtr[range];
3611 int i, offset;
3612 unsigned char *site;
3613
3614 if (rangePtr->type != LOOP_EXCEPTION_RANGE) {
3615 Tcl_Panic("trying to finalize a loop exception range");
3616 }
3617
3618 /*
3619 * Do the jump fixups. Note that these are always issued as INST_JUMP4 so
3620 * there is no need to fuss around with updating code offsets.
3621 */
3622
3623 for (i=0 ; i<auxPtr->numBreakTargets ; i++) {
3624 site = envPtr->codeStart + auxPtr->breakTargets[i];
3625 offset = rangePtr->breakOffset - auxPtr->breakTargets[i];
3626 TclUpdateInstInt4AtPc(INST_JUMP4, offset, site);
3627 }
3628 for (i=0 ; i<auxPtr->numContinueTargets ; i++) {
3629 site = envPtr->codeStart + auxPtr->continueTargets[i];
3630 if (rangePtr->continueOffset == -1) {
3631 int j;
3632
3633 /*
3634 * WTF? Can't bind, so revert to an INST_CONTINUE. Not enough
3635 * space to do anything else.
3636 */
3637
3638 *site = INST_CONTINUE;
3639 for (j=0 ; j<4 ; j++) {
3640 *++site = INST_NOP;
3641 }
3642 } else {
3643 offset = rangePtr->continueOffset - auxPtr->continueTargets[i];
3644 TclUpdateInstInt4AtPc(INST_JUMP4, offset, site);
3645 }
3646 }
3647
3648 /*
3649 * Drop the arrays we were holding the only reference to.
3650 */
3651
3652 if (auxPtr->breakTargets) {
3653 ckfree(auxPtr->breakTargets);
3654 auxPtr->breakTargets = NULL;
3655 auxPtr->numBreakTargets = 0;
3656 }
3657 if (auxPtr->continueTargets) {
3658 ckfree(auxPtr->continueTargets);
3659 auxPtr->continueTargets = NULL;
3660 auxPtr->numContinueTargets = 0;
3661 }
3662 }
3663
3664 /*
3665 *----------------------------------------------------------------------
3666 *
3667 * TclCreateAuxData --
3668 *
3669 * Procedure that allocates and initializes a new AuxData structure in a
3670 * CompileEnv's array of compilation auxiliary data records. These
3671 * AuxData records hold information created during compilation by
3672 * CompileProcs and used by instructions during execution.
3673 *
3674 * Results:
3675 * Returns the index for the newly created AuxData structure.
3676 *
3677 * Side effects:
3678 * If there is not enough room in the CompileEnv's AuxData array, the
3679 * AuxData array in expanded: a new array of double the size is
3680 * allocated, if envPtr->mallocedAuxDataArray is non-zero the old array
3681 * is freed, and AuxData entries are copied from the old array to the new
3682 * one.
3683 *
3684 *----------------------------------------------------------------------
3685 */
3686
3687 int
TclCreateAuxData(ClientData clientData,const AuxDataType * typePtr,CompileEnv * envPtr)3688 TclCreateAuxData(
3689 ClientData clientData, /* The compilation auxiliary data to store in
3690 * the new aux data record. */
3691 const AuxDataType *typePtr, /* Pointer to the type to attach to this
3692 * AuxData */
3693 CompileEnv *envPtr)/* Points to the CompileEnv for which a new
3694 * aux data structure is to be allocated. */
3695 {
3696 int index; /* Index for the new AuxData structure. */
3697 AuxData *auxDataPtr;
3698 /* Points to the new AuxData structure */
3699
3700 index = envPtr->auxDataArrayNext;
3701 if (index >= envPtr->auxDataArrayEnd) {
3702 /*
3703 * Expand the AuxData array. The currently allocated entries are
3704 * stored between elements 0 and (envPtr->auxDataArrayNext - 1)
3705 * [inclusive].
3706 */
3707
3708 size_t currBytes = envPtr->auxDataArrayNext * sizeof(AuxData);
3709 int newElems = 2*envPtr->auxDataArrayEnd;
3710 size_t newBytes = newElems * sizeof(AuxData);
3711
3712 if (envPtr->mallocedAuxDataArray) {
3713 envPtr->auxDataArrayPtr =
3714 ckrealloc(envPtr->auxDataArrayPtr, newBytes);
3715 } else {
3716 /*
3717 * envPtr->auxDataArrayPtr isn't a ckalloc'd pointer, so we must
3718 * code a ckrealloc equivalent for ourselves.
3719 */
3720
3721 AuxData *newPtr = ckalloc(newBytes);
3722
3723 memcpy(newPtr, envPtr->auxDataArrayPtr, currBytes);
3724 envPtr->auxDataArrayPtr = newPtr;
3725 envPtr->mallocedAuxDataArray = 1;
3726 }
3727 envPtr->auxDataArrayEnd = newElems;
3728 }
3729 envPtr->auxDataArrayNext++;
3730
3731 auxDataPtr = &envPtr->auxDataArrayPtr[index];
3732 auxDataPtr->clientData = clientData;
3733 auxDataPtr->type = typePtr;
3734 return index;
3735 }
3736
3737 /*
3738 *----------------------------------------------------------------------
3739 *
3740 * TclInitJumpFixupArray --
3741 *
3742 * Initializes a JumpFixupArray structure to hold some number of jump
3743 * fixup entries.
3744 *
3745 * Results:
3746 * None.
3747 *
3748 * Side effects:
3749 * The JumpFixupArray structure is initialized.
3750 *
3751 *----------------------------------------------------------------------
3752 */
3753
3754 void
TclInitJumpFixupArray(JumpFixupArray * fixupArrayPtr)3755 TclInitJumpFixupArray(
3756 JumpFixupArray *fixupArrayPtr)
3757 /* Points to the JumpFixupArray structure to
3758 * initialize. */
3759 {
3760 fixupArrayPtr->fixup = fixupArrayPtr->staticFixupSpace;
3761 fixupArrayPtr->next = 0;
3762 fixupArrayPtr->end = JUMPFIXUP_INIT_ENTRIES - 1;
3763 fixupArrayPtr->mallocedArray = 0;
3764 }
3765
3766 /*
3767 *----------------------------------------------------------------------
3768 *
3769 * TclExpandJumpFixupArray --
3770 *
3771 * Procedure that uses malloc to allocate more storage for a jump fixup
3772 * array.
3773 *
3774 * Results:
3775 * None.
3776 *
3777 * Side effects:
3778 * The jump fixup array in *fixupArrayPtr is reallocated to a new array
3779 * of double the size, and if fixupArrayPtr->mallocedArray is non-zero
3780 * the old array is freed. Jump fixup structures are copied from the old
3781 * array to the new one.
3782 *
3783 *----------------------------------------------------------------------
3784 */
3785
3786 void
TclExpandJumpFixupArray(JumpFixupArray * fixupArrayPtr)3787 TclExpandJumpFixupArray(
3788 JumpFixupArray *fixupArrayPtr)
3789 /* Points to the JumpFixupArray structure to
3790 * enlarge. */
3791 {
3792 /*
3793 * The currently allocated jump fixup entries are stored from fixup[0] up
3794 * to fixup[fixupArrayPtr->fixupNext] (*not* inclusive). We assume
3795 * fixupArrayPtr->fixupNext is equal to fixupArrayPtr->fixupEnd.
3796 */
3797
3798 size_t currBytes = fixupArrayPtr->next * sizeof(JumpFixup);
3799 int newElems = 2*(fixupArrayPtr->end + 1);
3800 size_t newBytes = newElems * sizeof(JumpFixup);
3801
3802 if (fixupArrayPtr->mallocedArray) {
3803 fixupArrayPtr->fixup = ckrealloc(fixupArrayPtr->fixup, newBytes);
3804 } else {
3805 /*
3806 * fixupArrayPtr->fixup isn't a ckalloc'd pointer, so we must code a
3807 * ckrealloc equivalent for ourselves.
3808 */
3809
3810 JumpFixup *newPtr = ckalloc(newBytes);
3811
3812 memcpy(newPtr, fixupArrayPtr->fixup, currBytes);
3813 fixupArrayPtr->fixup = newPtr;
3814 fixupArrayPtr->mallocedArray = 1;
3815 }
3816 fixupArrayPtr->end = newElems;
3817 }
3818
3819 /*
3820 *----------------------------------------------------------------------
3821 *
3822 * TclFreeJumpFixupArray --
3823 *
3824 * Free any storage allocated in a jump fixup array structure.
3825 *
3826 * Results:
3827 * None.
3828 *
3829 * Side effects:
3830 * Allocated storage in the JumpFixupArray structure is freed.
3831 *
3832 *----------------------------------------------------------------------
3833 */
3834
3835 void
TclFreeJumpFixupArray(JumpFixupArray * fixupArrayPtr)3836 TclFreeJumpFixupArray(
3837 JumpFixupArray *fixupArrayPtr)
3838 /* Points to the JumpFixupArray structure to
3839 * free. */
3840 {
3841 if (fixupArrayPtr->mallocedArray) {
3842 ckfree(fixupArrayPtr->fixup);
3843 }
3844 }
3845
3846 /*
3847 *----------------------------------------------------------------------
3848 *
3849 * TclEmitForwardJump --
3850 *
3851 * Procedure to emit a two-byte forward jump of kind "jumpType". Since
3852 * the jump may later have to be grown to five bytes if the jump target
3853 * is more than, say, 127 bytes away, this procedure also initializes a
3854 * JumpFixup record with information about the jump.
3855 *
3856 * Results:
3857 * None.
3858 *
3859 * Side effects:
3860 * The JumpFixup record pointed to by "jumpFixupPtr" is initialized with
3861 * information needed later if the jump is to be grown. Also, a two byte
3862 * jump of the designated type is emitted at the current point in the
3863 * bytecode stream.
3864 *
3865 *----------------------------------------------------------------------
3866 */
3867
3868 void
TclEmitForwardJump(CompileEnv * envPtr,TclJumpType jumpType,JumpFixup * jumpFixupPtr)3869 TclEmitForwardJump(
3870 CompileEnv *envPtr, /* Points to the CompileEnv structure that
3871 * holds the resulting instruction. */
3872 TclJumpType jumpType, /* Indicates the kind of jump: if true or
3873 * false or unconditional. */
3874 JumpFixup *jumpFixupPtr) /* Points to the JumpFixup structure to
3875 * initialize with information about this
3876 * forward jump. */
3877 {
3878 /*
3879 * Initialize the JumpFixup structure:
3880 * - codeOffset is offset of first byte of jump below
3881 * - cmdIndex is index of the command after the current one
3882 * - exceptIndex is the index of the first ExceptionRange after the
3883 * current one.
3884 */
3885
3886 jumpFixupPtr->jumpType = jumpType;
3887 jumpFixupPtr->codeOffset = envPtr->codeNext - envPtr->codeStart;
3888 jumpFixupPtr->cmdIndex = envPtr->numCommands;
3889 jumpFixupPtr->exceptIndex = envPtr->exceptArrayNext;
3890
3891 switch (jumpType) {
3892 case TCL_UNCONDITIONAL_JUMP:
3893 TclEmitInstInt1(INST_JUMP1, 0, envPtr);
3894 break;
3895 case TCL_TRUE_JUMP:
3896 TclEmitInstInt1(INST_JUMP_TRUE1, 0, envPtr);
3897 break;
3898 default:
3899 TclEmitInstInt1(INST_JUMP_FALSE1, 0, envPtr);
3900 break;
3901 }
3902 }
3903
3904 /*
3905 *----------------------------------------------------------------------
3906 *
3907 * TclFixupForwardJump --
3908 *
3909 * Procedure that updates a previously-emitted forward jump to jump a
3910 * specified number of bytes, "jumpDist". If necessary, the jump is grown
3911 * from two to five bytes; this is done if the jump distance is greater
3912 * than "distThreshold" (normally 127 bytes). The jump is described by a
3913 * JumpFixup record previously initialized by TclEmitForwardJump.
3914 *
3915 * Results:
3916 * 1 if the jump was grown and subsequent instructions had to be moved;
3917 * otherwise 0. This result is returned to allow callers to update any
3918 * additional code offsets they may hold.
3919 *
3920 * Side effects:
3921 * The jump may be grown and subsequent instructions moved. If this
3922 * happens, the code offsets for any commands and any ExceptionRange
3923 * records between the jump and the current code address will be updated
3924 * to reflect the moved code. Also, the bytecode instruction array in the
3925 * CompileEnv structure may be grown and reallocated.
3926 *
3927 *----------------------------------------------------------------------
3928 */
3929
3930 int
TclFixupForwardJump(CompileEnv * envPtr,JumpFixup * jumpFixupPtr,int jumpDist,int distThreshold)3931 TclFixupForwardJump(
3932 CompileEnv *envPtr, /* Points to the CompileEnv structure that
3933 * holds the resulting instruction. */
3934 JumpFixup *jumpFixupPtr, /* Points to the JumpFixup structure that
3935 * describes the forward jump. */
3936 int jumpDist, /* Jump distance to set in jump instr. */
3937 int distThreshold) /* Maximum distance before the two byte jump
3938 * is grown to five bytes. */
3939 {
3940 unsigned char *jumpPc, *p;
3941 int firstCmd, lastCmd, firstRange, lastRange, k;
3942 unsigned numBytes;
3943
3944 if (jumpDist <= distThreshold) {
3945 jumpPc = envPtr->codeStart + jumpFixupPtr->codeOffset;
3946 switch (jumpFixupPtr->jumpType) {
3947 case TCL_UNCONDITIONAL_JUMP:
3948 TclUpdateInstInt1AtPc(INST_JUMP1, jumpDist, jumpPc);
3949 break;
3950 case TCL_TRUE_JUMP:
3951 TclUpdateInstInt1AtPc(INST_JUMP_TRUE1, jumpDist, jumpPc);
3952 break;
3953 default:
3954 TclUpdateInstInt1AtPc(INST_JUMP_FALSE1, jumpDist, jumpPc);
3955 break;
3956 }
3957 return 0;
3958 }
3959
3960 /*
3961 * We must grow the jump then move subsequent instructions down. Note that
3962 * if we expand the space for generated instructions, code addresses might
3963 * change; be careful about updating any of these addresses held in
3964 * variables.
3965 */
3966
3967 if ((envPtr->codeNext + 3) > envPtr->codeEnd) {
3968 TclExpandCodeArray(envPtr);
3969 }
3970 jumpPc = envPtr->codeStart + jumpFixupPtr->codeOffset;
3971 numBytes = envPtr->codeNext-jumpPc-2;
3972 p = jumpPc+2;
3973 memmove(p+3, p, numBytes);
3974
3975 envPtr->codeNext += 3;
3976 jumpDist += 3;
3977 switch (jumpFixupPtr->jumpType) {
3978 case TCL_UNCONDITIONAL_JUMP:
3979 TclUpdateInstInt4AtPc(INST_JUMP4, jumpDist, jumpPc);
3980 break;
3981 case TCL_TRUE_JUMP:
3982 TclUpdateInstInt4AtPc(INST_JUMP_TRUE4, jumpDist, jumpPc);
3983 break;
3984 default:
3985 TclUpdateInstInt4AtPc(INST_JUMP_FALSE4, jumpDist, jumpPc);
3986 break;
3987 }
3988
3989 /*
3990 * Adjust the code offsets for any commands and any ExceptionRange records
3991 * between the jump and the current code address.
3992 */
3993
3994 firstCmd = jumpFixupPtr->cmdIndex;
3995 lastCmd = envPtr->numCommands - 1;
3996 if (firstCmd < lastCmd) {
3997 for (k = firstCmd; k <= lastCmd; k++) {
3998 envPtr->cmdMapPtr[k].codeOffset += 3;
3999 }
4000 }
4001
4002 firstRange = jumpFixupPtr->exceptIndex;
4003 lastRange = envPtr->exceptArrayNext - 1;
4004 for (k = firstRange; k <= lastRange; k++) {
4005 ExceptionRange *rangePtr = &envPtr->exceptArrayPtr[k];
4006
4007 rangePtr->codeOffset += 3;
4008 switch (rangePtr->type) {
4009 case LOOP_EXCEPTION_RANGE:
4010 rangePtr->breakOffset += 3;
4011 if (rangePtr->continueOffset != -1) {
4012 rangePtr->continueOffset += 3;
4013 }
4014 break;
4015 case CATCH_EXCEPTION_RANGE:
4016 rangePtr->catchOffset += 3;
4017 break;
4018 default:
4019 Tcl_Panic("TclFixupForwardJump: bad ExceptionRange type %d",
4020 rangePtr->type);
4021 }
4022 }
4023
4024 for (k = 0 ; k < envPtr->exceptArrayNext ; k++) {
4025 ExceptionAux *auxPtr = &envPtr->exceptAuxArrayPtr[k];
4026 int i;
4027
4028 for (i=0 ; i<auxPtr->numBreakTargets ; i++) {
4029 if (jumpFixupPtr->codeOffset < auxPtr->breakTargets[i]) {
4030 auxPtr->breakTargets[i] += 3;
4031 }
4032 }
4033 for (i=0 ; i<auxPtr->numContinueTargets ; i++) {
4034 if (jumpFixupPtr->codeOffset < auxPtr->continueTargets[i]) {
4035 auxPtr->continueTargets[i] += 3;
4036 }
4037 }
4038 }
4039
4040 return 1; /* the jump was grown */
4041 }
4042
4043 /*
4044 *----------------------------------------------------------------------
4045 *
4046 * TclEmitInvoke --
4047 *
4048 * Emit one of the invoke-related instructions, wrapping it if necessary
4049 * in code that ensures that any break or continue operation passing
4050 * through it gets the stack unwinding correct, converting it into an
4051 * internal jump if in an appropriate context.
4052 *
4053 * Results:
4054 * None
4055 *
4056 * Side effects:
4057 * Issues the jump with all correct stack management. May create another
4058 * loop exception range; pointers to ExceptionRange and ExceptionAux
4059 * structures should not be held across this call.
4060 *
4061 *----------------------------------------------------------------------
4062 */
4063
4064 void
TclEmitInvoke(CompileEnv * envPtr,int opcode,...)4065 TclEmitInvoke(
4066 CompileEnv *envPtr,
4067 int opcode,
4068 ...)
4069 {
4070 va_list argList;
4071 ExceptionRange *rangePtr;
4072 ExceptionAux *auxBreakPtr, *auxContinuePtr;
4073 int arg1, arg2, wordCount = 0, expandCount = 0;
4074 int loopRange = 0, breakRange = 0, continueRange = 0;
4075 int cleanup, depth = TclGetStackDepth(envPtr);
4076
4077 /*
4078 * Parse the arguments.
4079 */
4080
4081 va_start(argList, opcode);
4082 switch (opcode) {
4083 case INST_INVOKE_STK1:
4084 wordCount = arg1 = cleanup = va_arg(argList, int);
4085 arg2 = 0;
4086 break;
4087 case INST_INVOKE_STK4:
4088 wordCount = arg1 = cleanup = va_arg(argList, int);
4089 arg2 = 0;
4090 break;
4091 case INST_INVOKE_REPLACE:
4092 arg1 = va_arg(argList, int);
4093 arg2 = va_arg(argList, int);
4094 wordCount = arg1 + arg2 - 1;
4095 cleanup = arg1 + 1;
4096 break;
4097 default:
4098 Tcl_Panic("unexpected opcode");
4099 case INST_EVAL_STK:
4100 wordCount = cleanup = 1;
4101 arg1 = arg2 = 0;
4102 break;
4103 case INST_RETURN_STK:
4104 wordCount = cleanup = 2;
4105 arg1 = arg2 = 0;
4106 break;
4107 case INST_INVOKE_EXPANDED:
4108 wordCount = arg1 = cleanup = va_arg(argList, int);
4109 arg2 = 0;
4110 expandCount = 1;
4111 break;
4112 }
4113 va_end(argList);
4114
4115 /*
4116 * Determine if we need to handle break and continue exceptions with a
4117 * special handling exception range (so that we can correctly unwind the
4118 * stack).
4119 *
4120 * These must be done separately; they can be different (especially for
4121 * calls from inside a [for] increment clause).
4122 */
4123
4124 rangePtr = TclGetInnermostExceptionRange(envPtr, TCL_CONTINUE,
4125 &auxContinuePtr);
4126 if (rangePtr == NULL || rangePtr->type != LOOP_EXCEPTION_RANGE) {
4127 auxContinuePtr = NULL;
4128 } else if (auxContinuePtr->stackDepth == envPtr->currStackDepth-wordCount
4129 && auxContinuePtr->expandTarget == envPtr->expandCount-expandCount) {
4130 auxContinuePtr = NULL;
4131 } else {
4132 continueRange = auxContinuePtr - envPtr->exceptAuxArrayPtr;
4133 }
4134
4135 rangePtr = TclGetInnermostExceptionRange(envPtr, TCL_BREAK, &auxBreakPtr);
4136 if (rangePtr == NULL || rangePtr->type != LOOP_EXCEPTION_RANGE) {
4137 auxBreakPtr = NULL;
4138 } else if (auxContinuePtr == NULL
4139 && auxBreakPtr->stackDepth == envPtr->currStackDepth-wordCount
4140 && auxBreakPtr->expandTarget == envPtr->expandCount-expandCount) {
4141 auxBreakPtr = NULL;
4142 } else {
4143 breakRange = auxBreakPtr - envPtr->exceptAuxArrayPtr;
4144 }
4145
4146 if (auxBreakPtr != NULL || auxContinuePtr != NULL) {
4147 loopRange = TclCreateExceptRange(LOOP_EXCEPTION_RANGE, envPtr);
4148 ExceptionRangeStarts(envPtr, loopRange);
4149 }
4150
4151 /*
4152 * Issue the invoke itself.
4153 */
4154
4155 switch (opcode) {
4156 case INST_INVOKE_STK1:
4157 TclEmitInstInt1(INST_INVOKE_STK1, arg1, envPtr);
4158 break;
4159 case INST_INVOKE_STK4:
4160 TclEmitInstInt4(INST_INVOKE_STK4, arg1, envPtr);
4161 break;
4162 case INST_INVOKE_EXPANDED:
4163 TclEmitOpcode(INST_INVOKE_EXPANDED, envPtr);
4164 envPtr->expandCount--;
4165 TclAdjustStackDepth(1 - arg1, envPtr);
4166 break;
4167 case INST_EVAL_STK:
4168 TclEmitOpcode(INST_EVAL_STK, envPtr);
4169 break;
4170 case INST_RETURN_STK:
4171 TclEmitOpcode(INST_RETURN_STK, envPtr);
4172 break;
4173 case INST_INVOKE_REPLACE:
4174 TclEmitInstInt4(INST_INVOKE_REPLACE, arg1, envPtr);
4175 TclEmitInt1(arg2, envPtr);
4176 TclAdjustStackDepth(-1, envPtr); /* Correction to stack depth calcs */
4177 break;
4178 }
4179
4180 /*
4181 * If we're generating a special wrapper exception range, we need to
4182 * finish that up now.
4183 */
4184
4185 if (auxBreakPtr != NULL || auxContinuePtr != NULL) {
4186 int savedStackDepth = envPtr->currStackDepth;
4187 int savedExpandCount = envPtr->expandCount;
4188 JumpFixup nonTrapFixup;
4189
4190 if (auxBreakPtr != NULL) {
4191 auxBreakPtr = envPtr->exceptAuxArrayPtr + breakRange;
4192 }
4193 if (auxContinuePtr != NULL) {
4194 auxContinuePtr = envPtr->exceptAuxArrayPtr + continueRange;
4195 }
4196
4197 ExceptionRangeEnds(envPtr, loopRange);
4198 TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &nonTrapFixup);
4199
4200 /*
4201 * Careful! When generating these stack unwinding sequences, the depth
4202 * of stack in the cases where they are taken is not the same as if
4203 * the exception is not taken.
4204 */
4205
4206 if (auxBreakPtr != NULL) {
4207 TclAdjustStackDepth(-1, envPtr);
4208
4209 ExceptionRangeTarget(envPtr, loopRange, breakOffset);
4210 TclCleanupStackForBreakContinue(envPtr, auxBreakPtr);
4211 TclAddLoopBreakFixup(envPtr, auxBreakPtr);
4212 TclAdjustStackDepth(1, envPtr);
4213
4214 envPtr->currStackDepth = savedStackDepth;
4215 envPtr->expandCount = savedExpandCount;
4216 }
4217
4218 if (auxContinuePtr != NULL) {
4219 TclAdjustStackDepth(-1, envPtr);
4220
4221 ExceptionRangeTarget(envPtr, loopRange, continueOffset);
4222 TclCleanupStackForBreakContinue(envPtr, auxContinuePtr);
4223 TclAddLoopContinueFixup(envPtr, auxContinuePtr);
4224 TclAdjustStackDepth(1, envPtr);
4225
4226 envPtr->currStackDepth = savedStackDepth;
4227 envPtr->expandCount = savedExpandCount;
4228 }
4229
4230 TclFinalizeLoopExceptionRange(envPtr, loopRange);
4231 TclFixupForwardJumpToHere(envPtr, &nonTrapFixup, 127);
4232 }
4233 TclCheckStackDepth(depth+1-cleanup, envPtr);
4234 }
4235
4236 /*
4237 *----------------------------------------------------------------------
4238 *
4239 * TclGetInstructionTable --
4240 *
4241 * Returns a pointer to the table describing Tcl bytecode instructions.
4242 * This procedure is defined so that clients can access the pointer from
4243 * outside the TCL DLLs.
4244 *
4245 * Results:
4246 * Returns a pointer to the global instruction table, same as the
4247 * expression (&tclInstructionTable[0]).
4248 *
4249 * Side effects:
4250 * None.
4251 *
4252 *----------------------------------------------------------------------
4253 */
4254
4255 const void * /* == InstructionDesc* == */
TclGetInstructionTable(void)4256 TclGetInstructionTable(void)
4257 {
4258 return &tclInstructionTable[0];
4259 }
4260
4261 /*
4262 *----------------------------------------------------------------------
4263 *
4264 * GetCmdLocEncodingSize --
4265 *
4266 * Computes the total number of bytes needed to encode the command
4267 * location information for some compiled code.
4268 *
4269 * Results:
4270 * The byte count needed to encode the compiled location information.
4271 *
4272 * Side effects:
4273 * None.
4274 *
4275 *----------------------------------------------------------------------
4276 */
4277
4278 static int
GetCmdLocEncodingSize(CompileEnv * envPtr)4279 GetCmdLocEncodingSize(
4280 CompileEnv *envPtr) /* Points to compilation environment structure
4281 * containing the CmdLocation structure to
4282 * encode. */
4283 {
4284 CmdLocation *mapPtr = envPtr->cmdMapPtr;
4285 int numCmds = envPtr->numCommands;
4286 int codeDelta, codeLen, srcDelta, srcLen;
4287 int codeDeltaNext, codeLengthNext, srcDeltaNext, srcLengthNext;
4288 /* The offsets in their respective byte
4289 * sequences where the next encoded offset or
4290 * length should go. */
4291 int prevCodeOffset, prevSrcOffset, i;
4292
4293 codeDeltaNext = codeLengthNext = srcDeltaNext = srcLengthNext = 0;
4294 prevCodeOffset = prevSrcOffset = 0;
4295 for (i = 0; i < numCmds; i++) {
4296 codeDelta = mapPtr[i].codeOffset - prevCodeOffset;
4297 if (codeDelta < 0) {
4298 Tcl_Panic("GetCmdLocEncodingSize: bad code offset");
4299 } else if (codeDelta <= 127) {
4300 codeDeltaNext++;
4301 } else {
4302 codeDeltaNext += 5; /* 1 byte for 0xFF, 4 for positive delta */
4303 }
4304 prevCodeOffset = mapPtr[i].codeOffset;
4305
4306 codeLen = mapPtr[i].numCodeBytes;
4307 if (codeLen < 0) {
4308 Tcl_Panic("GetCmdLocEncodingSize: bad code length");
4309 } else if (codeLen <= 127) {
4310 codeLengthNext++;
4311 } else {
4312 codeLengthNext += 5;/* 1 byte for 0xFF, 4 for length */
4313 }
4314
4315 srcDelta = mapPtr[i].srcOffset - prevSrcOffset;
4316 if ((-127 <= srcDelta) && (srcDelta <= 127) && (srcDelta != -1)) {
4317 srcDeltaNext++;
4318 } else {
4319 srcDeltaNext += 5; /* 1 byte for 0xFF, 4 for delta */
4320 }
4321 prevSrcOffset = mapPtr[i].srcOffset;
4322
4323 srcLen = mapPtr[i].numSrcBytes;
4324 if (srcLen < 0) {
4325 Tcl_Panic("GetCmdLocEncodingSize: bad source length");
4326 } else if (srcLen <= 127) {
4327 srcLengthNext++;
4328 } else {
4329 srcLengthNext += 5; /* 1 byte for 0xFF, 4 for length */
4330 }
4331 }
4332
4333 return (codeDeltaNext + codeLengthNext + srcDeltaNext + srcLengthNext);
4334 }
4335
4336 /*
4337 *----------------------------------------------------------------------
4338 *
4339 * EncodeCmdLocMap --
4340 *
4341 * Encode the command location information for some compiled code into a
4342 * ByteCode structure. The encoded command location map is stored as
4343 * three adjacent byte sequences.
4344 *
4345 * Results:
4346 * Pointer to the first byte after the encoded command location
4347 * information.
4348 *
4349 * Side effects:
4350 * The encoded information is stored into the block of memory headed by
4351 * codePtr. Also records pointers to the start of the four byte sequences
4352 * in fields in codePtr's ByteCode header structure.
4353 *
4354 *----------------------------------------------------------------------
4355 */
4356
4357 static unsigned char *
EncodeCmdLocMap(CompileEnv * envPtr,ByteCode * codePtr,unsigned char * startPtr)4358 EncodeCmdLocMap(
4359 CompileEnv *envPtr, /* Points to compilation environment structure
4360 * containing the CmdLocation structure to
4361 * encode. */
4362 ByteCode *codePtr, /* ByteCode in which to encode envPtr's
4363 * command location information. */
4364 unsigned char *startPtr) /* Points to the first byte in codePtr's
4365 * memory block where the location information
4366 * is to be stored. */
4367 {
4368 CmdLocation *mapPtr = envPtr->cmdMapPtr;
4369 int numCmds = envPtr->numCommands;
4370 unsigned char *p = startPtr;
4371 int codeDelta, codeLen, srcDelta, srcLen, prevOffset;
4372 int i;
4373
4374 /*
4375 * Encode the code offset for each command as a sequence of deltas.
4376 */
4377
4378 codePtr->codeDeltaStart = p;
4379 prevOffset = 0;
4380 for (i = 0; i < numCmds; i++) {
4381 codeDelta = mapPtr[i].codeOffset - prevOffset;
4382 if (codeDelta < 0) {
4383 Tcl_Panic("EncodeCmdLocMap: bad code offset");
4384 } else if (codeDelta <= 127) {
4385 TclStoreInt1AtPtr(codeDelta, p);
4386 p++;
4387 } else {
4388 TclStoreInt1AtPtr(0xFF, p);
4389 p++;
4390 TclStoreInt4AtPtr(codeDelta, p);
4391 p += 4;
4392 }
4393 prevOffset = mapPtr[i].codeOffset;
4394 }
4395
4396 /*
4397 * Encode the code length for each command.
4398 */
4399
4400 codePtr->codeLengthStart = p;
4401 for (i = 0; i < numCmds; i++) {
4402 codeLen = mapPtr[i].numCodeBytes;
4403 if (codeLen < 0) {
4404 Tcl_Panic("EncodeCmdLocMap: bad code length");
4405 } else if (codeLen <= 127) {
4406 TclStoreInt1AtPtr(codeLen, p);
4407 p++;
4408 } else {
4409 TclStoreInt1AtPtr(0xFF, p);
4410 p++;
4411 TclStoreInt4AtPtr(codeLen, p);
4412 p += 4;
4413 }
4414 }
4415
4416 /*
4417 * Encode the source offset for each command as a sequence of deltas.
4418 */
4419
4420 codePtr->srcDeltaStart = p;
4421 prevOffset = 0;
4422 for (i = 0; i < numCmds; i++) {
4423 srcDelta = mapPtr[i].srcOffset - prevOffset;
4424 if ((-127 <= srcDelta) && (srcDelta <= 127) && (srcDelta != -1)) {
4425 TclStoreInt1AtPtr(srcDelta, p);
4426 p++;
4427 } else {
4428 TclStoreInt1AtPtr(0xFF, p);
4429 p++;
4430 TclStoreInt4AtPtr(srcDelta, p);
4431 p += 4;
4432 }
4433 prevOffset = mapPtr[i].srcOffset;
4434 }
4435
4436 /*
4437 * Encode the source length for each command.
4438 */
4439
4440 codePtr->srcLengthStart = p;
4441 for (i = 0; i < numCmds; i++) {
4442 srcLen = mapPtr[i].numSrcBytes;
4443 if (srcLen < 0) {
4444 Tcl_Panic("EncodeCmdLocMap: bad source length");
4445 } else if (srcLen <= 127) {
4446 TclStoreInt1AtPtr(srcLen, p);
4447 p++;
4448 } else {
4449 TclStoreInt1AtPtr(0xFF, p);
4450 p++;
4451 TclStoreInt4AtPtr(srcLen, p);
4452 p += 4;
4453 }
4454 }
4455
4456 return p;
4457 }
4458
4459 #ifdef TCL_COMPILE_STATS
4460 /*
4461 *----------------------------------------------------------------------
4462 *
4463 * RecordByteCodeStats --
4464 *
4465 * Accumulates various compilation-related statistics for each newly
4466 * compiled ByteCode. Called by the TclInitByteCodeObj when Tcl is
4467 * compiled with the -DTCL_COMPILE_STATS flag
4468 *
4469 * Results:
4470 * None.
4471 *
4472 * Side effects:
4473 * Accumulates aggregate code-related statistics in the interpreter's
4474 * ByteCodeStats structure. Records statistics specific to a ByteCode in
4475 * its ByteCode structure.
4476 *
4477 *----------------------------------------------------------------------
4478 */
4479
4480 void
RecordByteCodeStats(ByteCode * codePtr)4481 RecordByteCodeStats(
4482 ByteCode *codePtr) /* Points to ByteCode structure with info
4483 * to add to accumulated statistics. */
4484 {
4485 Interp *iPtr = (Interp *) *codePtr->interpHandle;
4486 ByteCodeStats *statsPtr;
4487
4488 if (iPtr == NULL) {
4489 /* Avoid segfaulting in case we're called in a deleted interp */
4490 return;
4491 }
4492 statsPtr = &(iPtr->stats);
4493
4494 statsPtr->numCompilations++;
4495 statsPtr->totalSrcBytes += (double) codePtr->numSrcBytes;
4496 statsPtr->totalByteCodeBytes += (double) codePtr->structureSize;
4497 statsPtr->currentSrcBytes += (double) codePtr->numSrcBytes;
4498 statsPtr->currentByteCodeBytes += (double) codePtr->structureSize;
4499
4500 statsPtr->srcCount[TclLog2(codePtr->numSrcBytes)]++;
4501 statsPtr->byteCodeCount[TclLog2((int) codePtr->structureSize)]++;
4502
4503 statsPtr->currentInstBytes += (double) codePtr->numCodeBytes;
4504 statsPtr->currentLitBytes += (double)
4505 codePtr->numLitObjects * sizeof(Tcl_Obj *);
4506 statsPtr->currentExceptBytes += (double)
4507 codePtr->numExceptRanges * sizeof(ExceptionRange);
4508 statsPtr->currentAuxBytes += (double)
4509 codePtr->numAuxDataItems * sizeof(AuxData);
4510 statsPtr->currentCmdMapBytes += (double) codePtr->numCmdLocBytes;
4511 }
4512 #endif /* TCL_COMPILE_STATS */
4513
4514 /*
4515 * Local Variables:
4516 * mode: c
4517 * c-basic-offset: 4
4518 * fill-column: 78
4519 * tab-width: 8
4520 * End:
4521 */
4522