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