Many hyperlinks are disabled.
Use anonymous login
to enable hyperlinks.
Overview
Comment: | A little bit less wrong. |
---|---|
Timelines: | family | ancestors | descendants | both | list-and-dict-types |
Files: | files | file ages | folders |
SHA3-256: |
75fd3b203eb858ad83f3b8edde5291fb |
User & Date: | dkf 2019-01-02 16:22:08 |
Context
2019-02-02
| ||
18:14 | Expansion... sort of Leaf check-in: 721be90d96 user: dkf tags: list-and-dict-types | |
2019-01-02
| ||
16:22 | A little bit less wrong. check-in: 75fd3b203e user: dkf tags: list-and-dict-types | |
2018-12-08
| ||
17:56 | merge trunk check-in: 01fb4f7ffb user: dkf tags: list-and-dict-types | |
Changes
Changes to codegen/build.tcl.
2138 2139 2140 2141 2142 2143 2144 2145 2146 2147 2148 2149 2150 2151 2152 .... 2157 2158 2159 2160 2161 2162 2163 2164 2165 2166 2167 2168 2169 2170 2171 .... 2179 2180 2181 2182 2183 2184 2185 2186 2187 2188 2189 2190 2191 2192 2193 .... 2204 2205 2206 2207 2208 2209 2210 2211 2212 2213 2214 2215 2216 2217 2218 .... 2225 2226 2227 2228 2229 2230 2231 2232 2233 2234 2235 2236 2237 2238 2239 .... 2245 2246 2247 2248 2249 2250 2251 2252 2253 2254 2255 2256 2257 2258 2259 2260 2261 2262 2263 .... 2270 2271 2272 2273 2274 2275 2276 2277 2278 2279 2280 2281 2282 2283 2284 .... 2288 2289 2290 2291 2292 2293 2294 2295 2296 2297 2298 2299 2300 2301 2302 .... 2378 2379 2380 2381 2382 2383 2384 2385 2386 2387 2388 2389 2390 2391 2392 .... 2401 2402 2403 2404 2405 2406 2407 2408 2409 2410 2411 2412 2413 2414 2415 .... 2421 2422 2423 2424 2425 2426 2427 2428 2429 2430 2431 2432 2433 2434 2435 .... 2440 2441 2442 2443 2444 2445 2446 2447 2448 2449 2450 2451 2452 2453 2454 .... 2460 2461 2462 2463 2464 2465 2466 2467 2468 2469 2470 2471 2472 2473 2474 .... 2479 2480 2481 2482 2483 2484 2485 2486 2487 2488 2489 2490 2491 2492 2493 .... 2495 2496 2497 2498 2499 2500 2501 2502 2503 2504 2505 2506 2507 2508 2509 2510 2511 2512 2513 2514 2515 2516 .... 2520 2521 2522 2523 2524 2525 2526 2527 2528 2529 2530 2531 2532 2533 2534 .... 2539 2540 2541 2542 2543 2544 2545 2546 2547 2548 2549 2550 2551 2552 2553 |
# value - The value to append as an LLVM value reference. # name (optional) - # A name to give to the result value. # # Results: # The resulting dictionary as an LLVM value reference. method dictAppend(EMPTY\040DICT,STRING,STRING) {dict key value {name ""}} { my call ${tcl.dict.append} [list $dict $key $value] $name } # Builder:dictExists(DICT) -- # # Find whether a key exists in a dictionary. This version uses a vector # of values for the key path. Quadcode implementation ('dictExists'). ................................................................................ # The key path as an LLVM vector value reference. # name (optional) - # A name to give to the result value. # # Results: # Whether the value exists as an LLVM ZEROONE value reference. method dictExists(EMPTY\040DICT) {dict vector {name ""}} { my ExtractVector $vector my call ${tcl.dict.exists} [list $dict $len $ary] $name } method dictExists(EMPTY) {dict vector {name ""}} { Const 0 int1 } ................................................................................ # key - The key as an LLVM value reference. # name (optional) - # A name to give to the result value. # # Results: # Whether the value exists as an LLVM ZEROONE value reference. method dictExists(EMPTY\040DICT,STRING) {dict key {name ""}} { my call ${tcl.dict.exists1} [list $dict $key] $name } method dictExists(EMPTY,STRING) {dict key {name ""}} { Const 0 int1 } # Builder:dictGet(DICT) -- ................................................................................ # ec - Where to write the error code if an error happens. # name (optional) - # A name to give to the result value. # # Results: # The retrieved value as an LLVM value reference, or a FAIL. method dictGet(EMPTY\040DICT) {dict vector ec {name ""}} { my ExtractVector $vector my call ${tcl.dict.get} [list $dict $len $ary $ec] $name } # Builder:dictGet(DICT,STRING) -- # # Retrieve a value from a dictionary. This version uses a single simple ................................................................................ # ec - Where to write the error code if an error happens. # name (optional) - # A name to give to the result value. # # Results: # The retrieved value as an LLVM value reference, or a FAIL. method dictGet(EMPTY\040DICT,STRING) {dict key ec {name ""}} { my call ${tcl.dict.get1} [list $dict $key $ec] $name } # Builder:dictGetOrNexist(EMPTY DICT,STRING) -- # # Retrieve a value from a dictionary, or NEXIST if the key doesn't map # to a value in the dict. This version uses a single simple key. ................................................................................ # ec - Where to write the error code if an error happens. # name (optional) - # A name to give to the result value. # # Results: # The retrieved value as an LLVM value reference, or a NEXIST. method dictGetOrNexist(EMPTY\040DICT,STRING) {dict key {name ""}} { my call ${tcl.dict.get1.empty} [list $dict $key] $name } method dictGetOrNexist(EMPTY,STRING) {dict key {name ""}} { # Should be possible to be efficient in this case! my call ${tcl.dict.get1.empty} [list $dict $key] $name } # Builder:dictIncr(EMPTY DICT,STRING,INT) -- # # Increment the value for a key in a dictionary. NOTE: this operation # can fail (e.g., because it can be given an invalid dictionary) so it ................................................................................ # ec - Where to write the error code if an error happens. # name (optional) - # A name to give to the result value. # # Results: # The resulting dictionary as an LLVM value reference, or a FAIL. method dictIncr(EMPTY\040DICT,STRING,INT) {dict key value ec {name ""}} { my call ${tcl.dict.incr} [list $dict $key $value $ec] $name } # Builder:dictIterStart(DICT) -- # # Start iterating over a dictionary; other opcodes are used to retrieve # what the state of the iteration is. Quadcode implementation ................................................................................ # dict - The dictionary as an LLVM value reference. # name (optional) - # A name to give to the result value. # # Results: # The iteration state as an LLVM DICTITER value reference. method dictIterStart(EMPTY\040DICT) {dict {name ""}} { my call ${tcl.dict.iterStart} [list $dict] $name } # Builder:dictIterNext -- # # Get the next step when iterating over a dictionary; other opcodes are # used to retrieve what the state of the iteration is. Quadcode ................................................................................ # ec - Where to write the error code if an error happens. # name (optional) - # A name to give to the result value. # # Results: # The resulting dictionary as an LLVM value reference, or a FAIL. method dictLappend(EMPTY\040DICT,STRING,STRING) {dict key value ec {name ""}} { my call ${tcl.dict.lappend} [list $dict $key $value $ec] $name } # Builder:dictSet(DICT,STRING) -- # # Set or create a value in a dictionary. This version uses a vector as a # dictionary key path.. NOTE: this operation can fail (e.g., because ................................................................................ # ec - Where to write the error code if an error happens. # name (optional) - # A name to give to the result value. # # Results: # The new dictionary value or a FAIL. method dictSet(EMPTY\040DICT,STRING) {dict value vector ec {name ""}} { my ExtractVector $vector my call ${tcl.dict.set} [list $dict $len $ary $value $ec] $name } # Builder:dictSet(DICT,STRING,STRING) -- # # Set or create a value in a dictionary. This version uses a single ................................................................................ # value - The value as an LLVM value reference. # name (optional) - # A name to give to the result value. # # Results: # The new dictionary value. method dictSet(EMPTY\040DICT,STRING,STRING) {dict key value {name ""}} { my call ${tcl.dict.set1} [list $dict $key $value] $name } # Builder:dictSetOrUnset(DICT,STRING,NEXIST) -- # # Remove a value in a dictionary. This version uses a single simple key. # Quadcode implementation ('dictSetOrUnset'). ................................................................................ # value - The NEXIST value (actually ignored). # name (optional) - # A name to give to the result value. # # Results: # The new dictionary value. method dictSetOrUnset(EMPTY\040DICT,STRING,NEXIST) {dict key value {name ""}} { my call ${tcl.dict.set1.empty} [list $dict $key [my nothing STRING]] $name } # Builder:dictSetOrUnset(DICT,STRING,NEXIST STRING) -- # # Set, create or remove a value in a dictionary. This version uses a # single simple key, and the value can be NEXIST to remove the key. ................................................................................ # value - The value as an LLVM value reference, or NEXIST. # name (optional) - # A name to give to the result value. # # Results: # The new dictionary value. method dictSetOrUnset(EMPTY\040DICT,STRING,NEXIST\040STRING) {dict key value {name ""}} { my call ${tcl.dict.set1.empty} [list $dict $key $value] $name } # Builder:dictSetOrUnset(DICT,STRING,NEXIST STRING) -- # # Set or create a value in a dictionary. This version uses a single # simple key. Quadcode implementation ('dictSetOrUnset'). ................................................................................ # value - The value as an LLVM value reference. # name (optional) - # A name to give to the result value. # # Results: # The new dictionary value. method dictSetOrUnset(EMPTY\040DICT,STRING,STRING) {dict key value {name ""}} { my call ${tcl.dict.set1.empty} [list $dict $key [my just $value]] $name } # Builder:dictSize(DICT) -- # # Get the size of a dictionary, i.e., the number of key-value pairs. # ................................................................................ # value - The STRING LLVM value reference to a dict to get the size of. # name (optional) - # A name to give to the result value. # # Results: # An INT in an LLVM value reference. method dictSize(EMPTY\040DICT) {value {name ""}} { my call ${tcl.dict.size} [list $value] $name } method dictSize(EMPTY) {value ecvar {name ""}} { my packInt32 [Const 0] $name } # Builder:dictUnset(EMPTY DICT) -- # # Remove a key from a dictionary. This version uses a vector as a # dictionary key path. NOTE: this operation can fail (e.g., because of # an invalid dictionary inside a valid one) so it produces a DICT FAIL. # Quadcode implementation ('dictUnset'). # # Parameters: ................................................................................ # ec - Where to write the error code if an error happens. # name (optional) - # A name to give to the result value. # # Results: # The new dictionary value. method dictUnset(EMPTY\040DICT) {dict vector ec {name ""}} { my ExtractVector $vector my call ${tcl.dict.unset} [list $dict $len $ary $ec] $name } # Builder:dictUnset(DICT,STRING) -- # # Remove a key from a dictionary. Quadcode implementation ('dictUnset'). ................................................................................ # ec - Where to write the error code if an error happens. (Ignored) # name (optional) - # A name to give to the result value. # # Results: # The new dictionary value. method dictUnset(EMPTY\040DICT,STRING) {dict key ec {name ""}} { my call ${tcl.dict.unset1} [list $dict $key] $name } # Builder:directAppend(STRING,STRING) -- # # Append a value to a variable, which should be referred to by a # fully-qualified name. NOTE: this operation can fail because of traces |
| > > > > | | | > > > > > | > > > > | | | > > > > > > > | > | > > > > | > > > > > | > > > > | > > > > | > > > > | > > > > | | | > > > > > | > > > > |
2138 2139 2140 2141 2142 2143 2144 2145 2146 2147 2148 2149 2150 2151 2152 2153 2154 2155 2156 .... 2161 2162 2163 2164 2165 2166 2167 2168 2169 2170 2171 2172 2173 2174 2175 .... 2183 2184 2185 2186 2187 2188 2189 2190 2191 2192 2193 2194 2195 2196 2197 .... 2208 2209 2210 2211 2212 2213 2214 2215 2216 2217 2218 2219 2220 2221 2222 2223 2224 2225 2226 2227 .... 2234 2235 2236 2237 2238 2239 2240 2241 2242 2243 2244 2245 2246 2247 2248 2249 2250 2251 2252 .... 2258 2259 2260 2261 2262 2263 2264 2265 2266 2267 2268 2269 2270 2271 2272 2273 2274 2275 2276 .... 2283 2284 2285 2286 2287 2288 2289 2290 2291 2292 2293 2294 2295 2296 2297 2298 2299 2300 2301 .... 2305 2306 2307 2308 2309 2310 2311 2312 2313 2314 2315 2316 2317 2318 2319 2320 2321 2322 2323 .... 2399 2400 2401 2402 2403 2404 2405 2406 2407 2408 2409 2410 2411 2412 2413 2414 2415 2416 2417 .... 2426 2427 2428 2429 2430 2431 2432 2433 2434 2435 2436 2437 2438 2439 2440 2441 2442 2443 2444 2445 .... 2451 2452 2453 2454 2455 2456 2457 2458 2459 2460 2461 2462 2463 2464 2465 2466 2467 2468 2469 .... 2474 2475 2476 2477 2478 2479 2480 2481 2482 2483 2484 2485 2486 2487 2488 2489 2490 2491 2492 .... 2498 2499 2500 2501 2502 2503 2504 2505 2506 2507 2508 2509 2510 2511 2512 2513 2514 2515 2516 .... 2521 2522 2523 2524 2525 2526 2527 2528 2529 2530 2531 2532 2533 2534 2535 2536 2537 2538 2539 .... 2541 2542 2543 2544 2545 2546 2547 2548 2549 2550 2551 2552 2553 2554 2555 2556 2557 2558 2559 2560 2561 2562 .... 2566 2567 2568 2569 2570 2571 2572 2573 2574 2575 2576 2577 2578 2579 2580 2581 2582 2583 2584 2585 .... 2590 2591 2592 2593 2594 2595 2596 2597 2598 2599 2600 2601 2602 2603 2604 2605 2606 2607 2608 |
# value - The value to append as an LLVM value reference. # name (optional) - # A name to give to the result value. # # Results: # The resulting dictionary as an LLVM value reference. method dictAppend(DICT,STRING,STRING) {dict key value {name ""}} { my call ${tcl.dict.append} [list $dict $key $value] $name } method dictAppend(EMPTY,STRING,STRING) {dict key value {name ""}} { # TODO: Optimize case? my call ${tcl.dict.append} [list $dict $key $value] $name } # Builder:dictExists(DICT) -- # # Find whether a key exists in a dictionary. This version uses a vector # of values for the key path. Quadcode implementation ('dictExists'). ................................................................................ # The key path as an LLVM vector value reference. # name (optional) - # A name to give to the result value. # # Results: # Whether the value exists as an LLVM ZEROONE value reference. method dictExists(DICT) {dict vector {name ""}} { my ExtractVector $vector my call ${tcl.dict.exists} [list $dict $len $ary] $name } method dictExists(EMPTY) {dict vector {name ""}} { Const 0 int1 } ................................................................................ # key - The key as an LLVM value reference. # name (optional) - # A name to give to the result value. # # Results: # Whether the value exists as an LLVM ZEROONE value reference. method dictExists(DICT,STRING) {dict key {name ""}} { my call ${tcl.dict.exists1} [list $dict $key] $name } method dictExists(EMPTY,STRING) {dict key {name ""}} { Const 0 int1 } # Builder:dictGet(DICT) -- ................................................................................ # ec - Where to write the error code if an error happens. # name (optional) - # A name to give to the result value. # # Results: # The retrieved value as an LLVM value reference, or a FAIL. method dictGet(DICT) {dict vector ec {name ""}} { my ExtractVector $vector my call ${tcl.dict.get} [list $dict $len $ary $ec] $name } method dictGet(EMPTY) {dict vector ec {name ""}} { # TODO: Optimize case? my ExtractVector $vector my call ${tcl.dict.get} [list $dict $len $ary $ec] $name } # Builder:dictGet(DICT,STRING) -- # # Retrieve a value from a dictionary. This version uses a single simple ................................................................................ # ec - Where to write the error code if an error happens. # name (optional) - # A name to give to the result value. # # Results: # The retrieved value as an LLVM value reference, or a FAIL. method dictGet(DICT,STRING) {dict key ec {name ""}} { my call ${tcl.dict.get1} [list $dict $key $ec] $name } method dictGet(EMPTY,STRING) {dict key ec {name ""}} { # TODO: Optimize case? my call ${tcl.dict.get1} [list $dict $key $ec] $name } # Builder:dictGetOrNexist(EMPTY DICT,STRING) -- # # Retrieve a value from a dictionary, or NEXIST if the key doesn't map # to a value in the dict. This version uses a single simple key. ................................................................................ # ec - Where to write the error code if an error happens. # name (optional) - # A name to give to the result value. # # Results: # The retrieved value as an LLVM value reference, or a NEXIST. method dictGetOrNexist(DICT,STRING) {dict key {name ""}} { my call ${tcl.dict.get1.empty} [list $dict $key] $name } method dictGetOrNexist(EMPTY,STRING) {dict key {name ""}} { # TODO: Optimize case my call ${tcl.dict.get1.empty} [list $dict $key] $name } # Builder:dictIncr(EMPTY DICT,STRING,INT) -- # # Increment the value for a key in a dictionary. NOTE: this operation # can fail (e.g., because it can be given an invalid dictionary) so it ................................................................................ # ec - Where to write the error code if an error happens. # name (optional) - # A name to give to the result value. # # Results: # The resulting dictionary as an LLVM value reference, or a FAIL. method dictIncr(DICT,STRING,INT) {dict key value ec {name ""}} { my call ${tcl.dict.incr} [list $dict $key $value $ec] $name } method dictIncr(EMPY,STRING,INT) {dict key value ec {name ""}} { # TODO: Optimize case my call ${tcl.dict.incr} [list $dict $key $value $ec] $name } # Builder:dictIterStart(DICT) -- # # Start iterating over a dictionary; other opcodes are used to retrieve # what the state of the iteration is. Quadcode implementation ................................................................................ # dict - The dictionary as an LLVM value reference. # name (optional) - # A name to give to the result value. # # Results: # The iteration state as an LLVM DICTITER value reference. method dictIterStart(DICT) {dict {name ""}} { my call ${tcl.dict.iterStart} [list $dict] $name } method dictIterStart(EMPTY) {dict {name ""}} { # TODO: Optimize case my call ${tcl.dict.iterStart} [list $dict] $name } # Builder:dictIterNext -- # # Get the next step when iterating over a dictionary; other opcodes are # used to retrieve what the state of the iteration is. Quadcode ................................................................................ # ec - Where to write the error code if an error happens. # name (optional) - # A name to give to the result value. # # Results: # The resulting dictionary as an LLVM value reference, or a FAIL. method dictLappend(DICT,STRING,STRING) {dict key value ec {name ""}} { my call ${tcl.dict.lappend} [list $dict $key $value $ec] $name } method dictLappend(EMPTY,STRING,STRING) {dict key value ec {name ""}} { # TODO: Optimize case my call ${tcl.dict.lappend} [list $dict $key $value $ec] $name } # Builder:dictSet(DICT,STRING) -- # # Set or create a value in a dictionary. This version uses a vector as a # dictionary key path.. NOTE: this operation can fail (e.g., because ................................................................................ # ec - Where to write the error code if an error happens. # name (optional) - # A name to give to the result value. # # Results: # The new dictionary value or a FAIL. method dictSet(DICT,STRING) {dict value vector ec {name ""}} { my ExtractVector $vector my call ${tcl.dict.set} [list $dict $len $ary $value $ec] $name } method dictSet(EMPTY,STRING) {dict value vector ec {name ""}} { # TODO: Optimize case my ExtractVector $vector my call ${tcl.dict.set} [list $dict $len $ary $value $ec] $name } # Builder:dictSet(DICT,STRING,STRING) -- # # Set or create a value in a dictionary. This version uses a single ................................................................................ # value - The value as an LLVM value reference. # name (optional) - # A name to give to the result value. # # Results: # The new dictionary value. method dictSet(DICT,STRING,STRING) {dict key value {name ""}} { my call ${tcl.dict.set1} [list $dict $key $value] $name } method dictSet(EMPTY,STRING,STRING) {dict key value {name ""}} { # TODO: Optimize case my call ${tcl.dict.set1} [list $dict $key $value] $name } # Builder:dictSetOrUnset(DICT,STRING,NEXIST) -- # # Remove a value in a dictionary. This version uses a single simple key. # Quadcode implementation ('dictSetOrUnset'). ................................................................................ # value - The NEXIST value (actually ignored). # name (optional) - # A name to give to the result value. # # Results: # The new dictionary value. method dictSetOrUnset(DICT,STRING,NEXIST) {dict key value {name ""}} { my call ${tcl.dict.set1.empty} [list $dict $key [my nothing STRING]] $name } method dictSetOrUnset(EMPTY,STRING,NEXIST) {dict key value {name ""}} { # TODO: Optimize case my call ${tcl.dict.set1.empty} [list $dict $key [my nothing STRING]] $name } # Builder:dictSetOrUnset(DICT,STRING,NEXIST STRING) -- # # Set, create or remove a value in a dictionary. This version uses a # single simple key, and the value can be NEXIST to remove the key. ................................................................................ # value - The value as an LLVM value reference, or NEXIST. # name (optional) - # A name to give to the result value. # # Results: # The new dictionary value. method dictSetOrUnset(DICT,STRING,NEXIST\040STRING) {dict key value {name ""}} { my call ${tcl.dict.set1.empty} [list $dict $key $value] $name } method dictSetOrUnset(EMPTY,STRING,NEXIST\040STRING) {dict key value {name ""}} { # TODO: Optimize case my call ${tcl.dict.set1.empty} [list $dict $key $value] $name } # Builder:dictSetOrUnset(DICT,STRING,NEXIST STRING) -- # # Set or create a value in a dictionary. This version uses a single # simple key. Quadcode implementation ('dictSetOrUnset'). ................................................................................ # value - The value as an LLVM value reference. # name (optional) - # A name to give to the result value. # # Results: # The new dictionary value. method dictSetOrUnset(DICT,STRING,STRING) {dict key value {name ""}} { my call ${tcl.dict.set1.empty} [list $dict $key [my just $value]] $name } method dictSetOrUnset(EMPTY,STRING,STRING) {dict key value {name ""}} { # TODO: Optimize case my call ${tcl.dict.set1.empty} [list $dict $key [my just $value]] $name } # Builder:dictSize(DICT) -- # # Get the size of a dictionary, i.e., the number of key-value pairs. # ................................................................................ # value - The STRING LLVM value reference to a dict to get the size of. # name (optional) - # A name to give to the result value. # # Results: # An INT in an LLVM value reference. method dictSize(DICT) {value {name ""}} { my call ${tcl.dict.size} [list $value] $name } method dictSize(EMPTY) {value ecvar {name ""}} { my packInt32 [Const 0] $name } # Builder:dictUnset(DICT) -- # # Remove a key from a dictionary. This version uses a vector as a # dictionary key path. NOTE: this operation can fail (e.g., because of # an invalid dictionary inside a valid one) so it produces a DICT FAIL. # Quadcode implementation ('dictUnset'). # # Parameters: ................................................................................ # ec - Where to write the error code if an error happens. # name (optional) - # A name to give to the result value. # # Results: # The new dictionary value. method dictUnset(DICT) {dict vector ec {name ""}} { my ExtractVector $vector my call ${tcl.dict.unset} [list $dict $len $ary $ec] $name } method dictUnset(EMPTY) {dict vector ec {name ""}} { # TODO: Optimize case my ExtractVector $vector my call ${tcl.dict.unset} [list $dict $len $ary $ec] $name } # Builder:dictUnset(DICT,STRING) -- # # Remove a key from a dictionary. Quadcode implementation ('dictUnset'). ................................................................................ # ec - Where to write the error code if an error happens. (Ignored) # name (optional) - # A name to give to the result value. # # Results: # The new dictionary value. method dictUnset(DICT,STRING) {dict key ec {name ""}} { my call ${tcl.dict.unset1} [list $dict $key] $name } method dictUnset(EMPTY,STRING) {dict key ec {name ""}} { # TODO: Optimize case my call ${tcl.dict.unset1} [list $dict $key] $name } # Builder:directAppend(STRING,STRING) -- # # Append a value to a variable, which should be referred to by a # fully-qualified name. NOTE: this operation can fail because of traces |
Changes to codegen/compile.tcl.
37 38 39 40 41 42 43 44 45 46 47 48 49 50 .. 54 55 56 57 58 59 60 61 62 63 64 65 66 67 ... 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 ... 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 ... 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 ... 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 ... 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 ... 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 ... 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 ... 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 ... 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 ... 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 ... 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 ... 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 ... 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 ... 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 ... 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 ... 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 ... 883 884 885 886 887 888 889 890 891 892 893 894 895 896 897 898 899 900 901 902 903 904 905 906 907 908 909 910 911 912 913 914 915 916 917 918 919 920 921 922 923 924 925 926 927 .... 1176 1177 1178 1179 1180 1181 1182 1183 1184 1185 1186 1187 1188 1189 1190 .... 1291 1292 1293 1294 1295 1296 1297 1298 1299 1300 1301 1302 1303 1304 1305 1306 1307 1308 1309 1310 1311 1312 1313 1314 1315 1316 1317 1318 1319 1320 1321 1322 1323 1324 1325 1326 1327 1328 1329 1330 .... 1356 1357 1358 1359 1360 1361 1362 1363 1364 1365 1366 1367 1368 1369 1370 .... 1384 1385 1386 1387 1388 1389 1390 1391 1392 1393 1394 1395 1396 1397 1398 .... 1504 1505 1506 1507 1508 1509 1510 1511 1512 1513 1514 1515 1516 1517 1518 1519 1520 1521 1522 1523 1524 1525 1526 .... 1537 1538 1539 1540 1541 1542 1543 1544 1545 1546 1547 1548 1549 1550 1551 1552 1553 1554 1555 1556 1557 1558 1559 1560 1561 .... 1588 1589 1590 1591 1592 1593 1594 1595 1596 1597 1598 1599 1600 1601 1602 1603 1604 1605 1606 .... 1722 1723 1724 1725 1726 1727 1728 1729 1730 1731 1732 1733 1734 1735 1736 .... 1859 1860 1861 1862 1863 1864 1865 1866 1867 1868 1869 1870 1871 1872 1873 1874 .... 1944 1945 1946 1947 1948 1949 1950 1951 1952 1953 1954 1955 1956 1957 1958 1959 1960 1961 .... 1970 1971 1972 1973 1974 1975 1976 1977 1978 1979 1980 1981 1982 1983 1984 .... 2021 2022 2023 2024 2025 2026 2027 2028 2029 2030 2031 2032 2033 2034 2035 .... 2037 2038 2039 2040 2041 2042 2043 2044 2045 2046 2047 2048 2049 2050 2051 .... 2229 2230 2231 2232 2233 2234 2235 2236 2237 2238 2239 2240 2241 2242 2243 2244 2245 2246 |
::quadcode::typeOfOperand \ ::quadcode::dataType::mightbea namespace eval tcl { namespace eval mathfunc { proc literal {descriptor} { string equal [lindex $descriptor 0] "literal" } proc refType {type} { expr { [uplevel 1 [list my ReferenceType? $type]] && "CALLFRAME" ni $type } } proc failType {type} { ................................................................................ uplevel 1 [list my OperandType $operand] } proc consumed {var search} { uplevel 1 [list my IsConsumed $var $search] } proc callframe {operand} { uplevel 1 [list my IsCallFrame $operand] } } } } # TclCompiler:ByteCode -- # ................................................................................ # # Results: # None. method PrintTypedQuads {channel qs} { set idx -1 set descriptions [lmap q $qs { concat "[incr idx]:" $q ":" [linsert [lmap arg [lrange $q 1 end] { try { if {$arg eq ""} { string cat VOID } elseif {[string match {pc *} $arg]} { string cat BLOCK } else { my ValueTypes $arg } } on error {} { string cat VOID } }] 1 \u21d0] }] if {$channel eq ""} { return [format "%s------>\n%s" $cmd [join $descriptions \n]] } else { puts $channel [format "%s------>\n%s" $cmd [join $descriptions \n]] } } ................................................................................ # NB: block(-1) is the function entry block. It's supposed to be # almost entirely optimized out. $block(-1) build-in $b $b @location 0 set errorCode [$b alloc int "tcl.errorCode"] set curr_block $block(-1) set 0 [$b int 0] ############################################################## # # Create debug info for variables in LLVM dict for {name typecode} $vtypes { lassign $name kind formalname origin set type [nameOfType $typecode] # Make the debugging information for the variable provided it is a # variable as perceived from the Tcl level. "Internal" temporary # variables aren't nearly so interesting. if {$kind eq "var"} { if {[lindex $quads $origin 0] eq "param"} { set idx [lsearch $bytecodeVars \ [list "scalar arg" $formalname]] if {$idx < 0} { return -code error \ "unmapped formal variable name: $formalname ($name)" } ................................................................................ my Warn "default injection for parameter %d of '%s'; injecting '%s'" \ [expr {$idx + 1}] [GetValueName [$func ref]] $defaultvalue set var [my LoadTypedLiteral $defaultvalue $type] } else { set var [$func param $idx $name] } set variables($tgt) $var if {[regexp {^IMPURE } $type] && "LIST" ni $type && "DICT" ni $type} { set var [$b stringifyImpure $var] set type STRING } if {refType($type)} { $b printref $var "param:" $b addReference($type) $var $b assume [$b shared $var] ................................................................................ "moveToCallFrame" { set mapping [lassign $l opcode tgt src] if {callframe($src)} { foreach {name value} $mapping { set name [lindex $name 1] set var [dict get $thevarmap $name] if {$value ne "Nothing"} { set op frame.store([my ValueTypes $value]) set value [my LoadOrLiteral $value] $b $op $value $theframe $var $name } else { $b frame.unset $theframe $var $name } } } my StoreResult $tgt [my LoadOrLiteral $src] } "retrieveResult" { lassign $l opcode tgt src if {[my ValueTypes $src] eq "CALLFRAME"} { set value [$b undef NOTHING] } elseif {"CALLFRAME" in [my ValueTypes $src]} { set value [$b frame.value [my LoadOrLiteral $src]] } else { set value [my LoadOrLiteral $src] my Warn "retrieveResult from non-callframe" } my StoreResult $tgt $value } "extractCallFrame" { lassign $l opcode tgt src if {callframe($src)} { set value [my LoadOrLiteral $src] if {[my ValueTypes $src] ne "CALLFRAME"} { set name [my LocalVarName $tgt] set value [$b frame.frame $value $name] } } else { set value $theframe } my StoreResult $tgt $value ................................................................................ my StoreResult $tgt \ [$b frame.load $theframe $var $vname $name] } } "result" { lassign $l opcode tgt src set name [my LocalVarName $tgt] append opcode ( [my ValueTypes $src] ) set src [my LoadOrLiteral $src] my StoreResult $tgt [$b $opcode $src $name] } "returnOptions" { lassign $l opcode tgt src ecode set srcs [lassign $l opcode tgt] set name [my LocalVarName $tgt] ................................................................................ append opcode ( [my ValueTypes {*}$srcs] ) set srcs [lmap s $srcs {my LoadOrLiteral $s}] my StoreResult $tgt [$b $opcode {*}$srcs $name] } "nsupvar" - "upvar" - "variable" { set srcs [lassign $l opcode tgt src] set localvar [lindex $srcs 0] if {[lindex $localvar 0] ne "literal"} { error "local variable must be literal" } set name [my LocalVarName $tgt] set var [dict get $thevarmap [lindex $localvar 1]] set op [dict get { nsupvar frame.bind.nsvar upvar frame.bind.upvar variable frame.bind.var } $opcode] append op ( [my ValueTypes {*}$srcs] ) set srcs [lmap s $srcs {my LoadOrLiteral $s}] set res [$b $op {*}$srcs $var $theframe $errorCode $name] if {"FAIL" in [my ValueTypes $tgt]} { my SetErrorLine $errorCode \ [$b maybe [$b frame.value $res]] } my StoreResult $tgt $res } "bitor" - "bitxor" - "bitand" - "lshift" - "rshift" - "add" - "sub" - "mult" - "uminus" - "uplus" - "land" - "lor" - ................................................................................ } "originCmd" { set srcs [lassign $l opcode tgt] set name [my LocalVarName $tgt] append opcode ( [my ValueTypes {*}$srcs] ) set srcs [lmap s $srcs {my LoadOrLiteral $s}] set res [$b $opcode {*}$srcs $errorCode $name] if {"FAIL" in [my ValueTypes $tgt]} { my SetErrorLine $errorCode [$b maybe $res] } my StoreResult $tgt $res } "list" { set srcs [lassign $l opcode tgt] set name [my LocalVarName $tgt] ................................................................................ my StoreResult $tgt [$b list $objv $srcs $types $name] } "strindex" { set srcs [lassign $l opcode tgt] set name [my LocalVarName $tgt] set srcs [my ConvertIndices 0 strlen 1] set res [$b $opcode {*}$srcs $errorCode $name] if {"FAIL" in [my ValueTypes $tgt]} { my SetErrorLine $errorCode [$b maybe $res] } my StoreResult $tgt $res } "strrange" - "strreplace" { set srcs [lassign $l opcode tgt] set name [my LocalVarName $tgt] set srcs [my ConvertIndices 0 strlen 1 2] set res [$b $opcode {*}$srcs $errorCode $name] if {"FAIL" in [my ValueTypes $tgt]} { my SetErrorLine $errorCode [$b maybe $res] } my StoreResult $tgt $res } "directGet" - "directSet" - "directAppend" - "directLappend" - "directLappendList" - "directUnset" - "directArrayGet" - "directArraySet" - "directArrayAppend" - ................................................................................ "dictAppend" - "dictIncr" - "dictLappend" - "dictSize" - "div" - "expon" - "mod" - "verifyList" - "dictGetOrNexist" - "dictSetOrUnset" { set srcs [lassign $l opcode tgt] set name [my LocalVarName $tgt] append opcode ( [my ValueTypes {*}$srcs] ) set srcs [lmap s $srcs {my LoadOrLiteral $s}] if {"FAIL" in [my ValueTypes $tgt]} { set res [$b $opcode {*}$srcs $errorCode $name] my SetErrorLine $errorCode [$b maybe $res] } else { set res [$b $opcode {*}$srcs $name] } my StoreResult $tgt $res } "listAppend" - "listConcat" - "listRange" { set srcs [lassign $l opcode tgt] set src1 [lindex $srcs 0] set name [my LocalVarName $tgt] append opcode ( [my ValueTypes {*}$srcs] ) set srcs [lmap s $srcs {my LoadOrLiteral $s}] if {consumed($src1, $pc + 1)} { set res [$b $opcode {*}$srcs $errorCode $name] } else { $b addReference([my ValueTypes $src1]) [lindex $srcs 0] set res [$b $opcode {*}$srcs $errorCode $name] $b dropReference([my ValueTypes $src1]) [lindex $srcs 0] } if {"FAIL" in [my ValueTypes $tgt]} { my SetErrorLine $errorCode [$b maybe $res] } my StoreResult $tgt $res } "returnCode" { lassign $l opcode tgt src set name [my LocalVarName $tgt] append opcode ( [my ValueTypes $src] ) my StoreResult $tgt \ [$b $opcode [my LoadOrLiteral $src] \ [$b load $errorCode] $name] } "initException" { my IssueException $l } "setReturnCode" { lassign $l opcode tgt src append opcode ( [my ValueTypes $src] ) my StoreResult $tgt \ [$b $opcode [my LoadOrLiteral $src] $errorCode] } "procLeave" { set srcs [lassign $l opcode tgt] set name [my LocalVarName $tgt] append opcode ( [my ValueTypes {*}$srcs] ) ................................................................................ set srcs [list $srcObj {*}$srcs] append opcode ( [my ValueTypes {*}$srcs] ) set srcs [lmap s $srcs {my LoadOrLiteral $s}] set res [$b $opcode {*}$srcs $errorCode $name] my StoreResult $tgt $res } else { # Need to construct the variadic path set vectortypes [lmap s $srcs {my ValueTypes $s}] set vector [$b buildVector $objv $vectortypes \ [lmap s $srcs {my LoadOrLiteral $s}]] append opcode ( [my ValueTypes $srcObj] ) set srcObj [my LoadOrLiteral $srcObj] set res [$b $opcode $srcObj $vector $errorCode $name] my StoreResult $tgt $res $b clearVector $vector } if {"FAIL" in [my ValueTypes $tgt]} { my SetErrorLine $errorCode [$b maybe $res] } } "dictSet" { set srcs [lassign $l opcode tgt srcObj srcValue] set name [my LocalVarName $tgt] if {[llength $srcs] == 1} { ................................................................................ set srcs [list $srcObj {*}$srcs $srcValue] append opcode ( [my ValueTypes {*}$srcs] ) set srcs [lmap s $srcs {my LoadOrLiteral $s}] set res [$b $opcode {*}$srcs $name] my StoreResult $tgt $res } else { # Need to construct the variadic path set vectortypes [lmap s $srcs {my ValueTypes $s}] set vector [$b buildVector $objv $vectortypes \ [lmap s $srcs {my LoadOrLiteral $s}]] set srcs [list $srcObj $srcValue] append opcode ( [my ValueTypes {*}$srcs] ) set srcs [lmap s $srcs {my LoadOrLiteral $s}] set res [$b $opcode {*}$srcs $vector $errorCode $name] my StoreResult $tgt $res $b clearVector $vector my SetErrorLine $errorCode [$b maybe $res] } } "listSet" { set srcs [lassign $l opcode tgt srcObj srcValue] set name [my LocalVarName $tgt] if {[llength $srcs] == 1} { ................................................................................ set srcs [list $srcObj {*}$srcs $srcValue] append opcode ( [my ValueTypes {*}$srcs] ) set srcs [lmap s $srcs {my LoadOrLiteral $s}] set res [$b $opcode {*}$srcs $errorCode $name] my StoreResult $tgt $res } else { # Need to construct the variadic path set vectortypes [lmap s $srcs {my ValueTypes $s}] set vector [$b buildVector $objv $vectortypes \ [lmap s $srcs {my LoadOrLiteral $s}]] set srcs [list $srcObj $srcValue] append opcode ( [my ValueTypes {*}$srcs] ) set srcs [lmap s $srcs {my LoadOrLiteral $s}] set res [$b $opcode {*}$srcs $vector $errorCode $name] my StoreResult $tgt $res $b clearVector $vector } if {"FAIL" in [my ValueTypes $tgt]} { my SetErrorLine $errorCode [$b maybe $res] } } "copy" - "expand" { lassign $l opcode tgt src set value [my LoadOrLiteral $src] set type [my OperandType $tgt] ................................................................................ my StoreResult $tgt $value } "maptoint" { lassign $l opcode tgt src map def set map [lindex $map 1] set def [lindex $def 1] set name [my LocalVarName $tgt] append opcode ( [my ValueTypes $src] ) set src [my LoadOrLiteral $src] my StoreResult $tgt [$b $opcode $src $map $def $name] } "extractExists" - "extractMaybe" { my IssueExtract $l } "extractFail" { lassign $l opcode tgt src set name [my LocalVarName $tgt] append opcode ( [my ValueTypes $src] ) set src [my LoadOrLiteral $src] my StoreResult $tgt [$b $opcode $src $name] } "purify" { lassign $l opcode tgt src set value [my LoadOrLiteral $src] set srctype [my OperandType $src] if {"IMPURE" ni $srctype} { return -code error \ "Trying to purify something that is not impure" } set name [my LocalVarName $tgt] if {"LIST" ni $srctype && "DICT" ni $srctype} { set value [$b impure.value $value $name] } ................................................................................ lassign $l opcode tgt src set type [my OperandType $src] if {$src ni $consumed} { if {$type eq "VOID"} { # VOID is trivial to free } elseif {refType($type)} { $b printref $variables($src) "free:" set vt [my ValueTypes $src] if {"ARRAY" in $vt} { # TRICKY POINT: need variable name to unset an array set name [Const [my LocalVarName $tgt] STRING] $b dropReference($vt) $variables($src) $name } else { $b dropReference($vt) $variables($src) } ................................................................................ $b br $block($tgt) } } "jumpTrue" { lassign $l opcode tgt src set name [my LocalVarName $src] set tgt [lindex $tgt 1] set mth isTrue([my ValueTypes $src]) set test [$b $mth [my LoadOrLiteral $src] test_$name] $b condBr $test $block($tgt) $ipath($pc) } "jumpFalse" { lassign $l opcode tgt src set name [my LocalVarName $src] set tgt [lindex $tgt 1] set mth isTrue([my ValueTypes $src]) set test [$b $mth [my LoadOrLiteral $src] test_$name] $b condBr $test $ipath($pc) $block($tgt) } "jump" { $b br $block([lindex $l 1 1]) } "return" { lassign $l opcode -> frame src set val [my LoadOrLiteral $src] if {"CALLFRAME" in [my ValueTypes $src]} { # The CALLFRAME does not leave set val [$b frame.value $val] } set type [nameOfType $returnType] if {refType($type)} { $b printref $val "ret:" if {literal($src)} { ................................................................................ } } } "frameArgs" { lassign $l opcode tgt src set name [my LocalVarName $tgt] set opcode frame.args append opcode ( [my ValueTypes $src] ) set val [my LoadOrLiteral $src] set result [$b $opcode $val $theframe $name] my StoreResult $tgt $result } "frameDepth" { lassign $l opcode tgt set name [my LocalVarName $tgt] ................................................................................ lappend consumed $src1 } else { set result [$b unshareCopy($type) $val $name] } $b printref $result "cat:" foreach src $srcs { set val [my LoadOrLiteral $src] $b appendString([my ValueTypes $src]) $val $result } my StoreResult $tgt $result } "concat" { set srcs [lassign $l opcode tgt] # Need to construct the variadic vector set vectortypes [lmap s $srcs {my ValueTypes $s}] set vector [$b buildVector $objv $vectortypes \ [lmap s $srcs {my LoadOrLiteral $s}]] set name [my LocalVarName $tgt] set result [$b concat() $vector $name] my StoreResult $tgt $result $b clearVector $vector } "foreachStart" { set srcs [lassign $l opcode tgt assign] set listtypes [lmap s $srcs {my ValueTypes $s}] set lists [lmap s $srcs {my LoadOrLiteral $s}] set result [$b foreachStart \ [lindex $assign 1] $lists \ $listtypes $errorCode] if {"FAIL" in [my ValueTypes $tgt]} { my SetErrorLine $errorCode [$b maybe $result] } my StoreResult $tgt $result } "unshareList" { lassign $l opcode tgt src set name [my LocalVarName $tgt] append opcode ( [my ValueTypes $src] ) set result [$b $opcode [my LoadOrLiteral $src] $name] my StoreResult $tgt $result } "foreachIter" - "foreachAdvance" - "foreachMayStep" - "dictIterKey" - "dictIterValue" - "dictIterDone" - "dictIterNext" { lassign $l opcode tgt src ................................................................................ set varmeta [dict get $bytecode variables] set argtypes {STRING} set arguments [list [list literal $cmd]] foreach vinfo $varmeta { if {"arg" in [lindex $vinfo 0]} { set vname [list var [lindex $vinfo 1] [llength $arguments]] lappend arguments $vname lappend argtypes [my ValueTypes $vname] } } # Patch in the extra variables discovered during quadcode analysis; # these are never arguments as Tcl always correctly puts those in the # original bytecode descriptor. set stdnames [lmap vinfo $varmeta {lindex $vinfo 1}] ................................................................................ } method IssueInvokeFunction {tgt func arguments vname} { upvar 1 callframe callframe thecallframe thecallframe set BASETYPES {ZEROONE INT DOUBLE NUMERIC STRING} set result [$b call $func $arguments $vname] if {[my ValueTypes $tgt] eq "FAIL"} { $b store $result $errorCode my SetErrorLine $errorCode } else { set ts [lmap t $BASETYPES {Type $t?}] if {[TypeOf $result] in $ts} { $b store [$b extract $result 0] $errorCode } elseif {[Type [TypeOf $result]?] eq [Type [my ValueTypes $tgt]]} { # Managed to prove non-failure in this case... set result [$b ok $result] } if {"FAIL" in [my ValueTypes $tgt]} { my SetErrorLine $errorCode [$b maybe $result] } } if {callframe($thecallframe)} { set result [$b frame.pack $callframe $result] } my StoreResult $tgt $result } method IssueInvokeCommand {tgt resolved arguments argvals vname} { upvar 1 callframe callframe thecallframe thecallframe set types [lmap s $arguments {my ValueTypes $s}] if {$resolved ne ""} { # FIXME: this causes wrong "wrong # args" messages set argvals [lreplace $argvals 0 0 $resolved] } set vector [$b buildVector $objv $types $argvals] set result [$b invoke $vector \ [expr {callframe($thecallframe)}] $callframe \ ................................................................................ method IssueInvokeExpanded {callframe operation} { set arguments [lassign $operation opcode tgt thecallframe] set vname [my LocalVarName $tgt] set expandPositions [lmap s $arguments { expr {"EXPANDED" in [my OperandType $s]} }] set argvals [lmap s $arguments {my LoadOrLiteral $s}] set types [lmap s $arguments {my ValueTypes $s}] set vector [$b buildVector $objv $types $argvals] set flags [$b buildBitArray $bitv $expandPositions] set result [$b invokeExpanded $vector $flags $errorCode $vname] my SetErrorLine $errorCode [$b maybe $result] if {callframe($thecallframe)} { set result [$b frame.pack $callframe $result] } ................................................................................ # # Results: # none method IssueWiden {operation} { lassign $operation opcode tgt src set name [my LocalVarName $tgt] set srctype [my ValueTypes $src] set tgttype [lindex $opcode 2] if {$tgttype eq ""} { set tgttype [my OperandType $tgt] } if {$srctype in {"VOID" "NOTHING" "NEXIST"}} { switch -glob -- $tgttype { "FAIL *" { ................................................................................ if {"STRING" in $tgttype && ("LIST" in $srctype || "DICT" in $srctype)} { return $value } # IMPURE to IMPURE - Copy the string value, and promote the # inner value if {[lindex $tgttype 0] eq "IMPURE" && [lindex $srctype 0] eq "IMPURE"} { set itgttype [lrange $tgttype 1 end] set isrctype [lrange $srctype 1 end] set ivalue [my WidenedValue [$b impure.value $value] \ $isrctype $itgttype] set svalue [$b impure.string $value] set value [$b impure $itgttype $svalue $ivalue $name] } elseif {[lindex $srctype 0] eq "IMPURE" && "STRING" in $tgttype} { set value [$b stringifyImpure $value $name] } elseif {[regexp {^IMPURE (.*)$} $tgttype -> innertype]} { set widened [my WidenedValue $value $srctype $innertype] set value [$b packImpure($innertype) $widened $name] } elseif {$tgttype eq "ZEROONE BOOLEAN"} { if {$srctype in {"ZEROONE" "BOOLEAN"}} { # do nothing - the internal reps are the same ................................................................................ if {$srctype eq "DOUBLE"} { set value [$b packNumericDouble $value $name] } else { set value [$b packNumericInt $value $name] } } elseif {$srctype eq "EMPTY" && $tgttype eq "STRING"} { set value [Const "" STRING] } elseif {$srctype ne $tgttype} { if {("DICT" in $srctype || "LIST" in $srctype) && "LIST" in $tgttype} { # Do nothing and hope! } else { my Warn "unimplemented convert from '%s' to '%s'" $srctype $tgttype } } if {[Type $tgttype] eq [Type [TypeOf $value]?]} { set value [$b ok $value] } elseif {[Type $tgttype] eq [Type [TypeOf $value]!]} { set value [$b just $value] } return $value } # TclCompiler:IssueDictExists -- # # Generate the code for testing whether an element of a dictionary ................................................................................ return } elseif {[llength $srcs] == 0 && $srcDict eq "literal \uf8ff"} { my StoreResult $tgt [my LoadOrLiteral "literal 0"] return } # Need to construct the variadic vector set types [lmap s $srcs {my ValueTypes $s}] set vector [$b buildVector $objv $types \ [lmap s $srcs {my LoadOrLiteral $s}]] set name [my LocalVarName $tgt] append opcode ( [my ValueTypes $srcDict] ) set srcDict [my LoadOrLiteral $srcDict] my StoreResult $tgt [$b $opcode $srcDict $vector $name] $b clearVector $vector return } # TclCompiler:IssueExtract -- ................................................................................ # Results: # none method IssueException {operation} { upvar 1 errorCode errorCode set srcs [lassign $operation opcode tgt src] set src2 [lindex $srcs 0] set maintype [my ValueTypes $src] set name [my LocalVarName $tgt] append opcode ( [my ValueTypes {*}$srcs] ) set value [my LoadOrLiteral $src] # Check if we can issue more efficient code by understanding the # literals provided (if everything is non-literal, we can't do much). if {[llength $srcs] == 3 && literal($src2)} { ................................................................................ # # Results: # A Tcl boolean value. method IsCallFrame {operand} { variable ::quadcode::dataType::CALLFRAME return [expr {[lindex $operand 0] in {"var" "temp"} && ([typeOfOperand $vtypes $operand] & $CALLFRAME) != 0}] } # TclCompiler:ValueTypes -- # # Convert the sequence of arguments (to an opcode) into the type # signature tuple to use with the name of the method in the Build class # to enable automatic type widening. ................................................................................ if {[info exist variables($desc)]} { return $variables($desc) } if {$desc eq "Nothing"} { # NEXIST special case return "Nothing" } lassign $desc kind value if {$kind ne "literal"} { return -code error "unsubstitutable argument: $desc" } set type [nameOfType [typeOfLiteral $value]] return [my LoadTypedLiteral $value $type] } # TclCompiler:LoadTypedLiteral -- # # Generate the code to create a LLVM value reference, given the ................................................................................ # # Maintainer note: # DO NOT do reference count management in this function! It makes things # leak or triggers use-after-free crashes. Leave that to the main # compiler engine (and the STRING allocator) as that gets it right. method LoadTypedLiteral {value type} { if {[lindex $type 0] eq "IMPURE"} { set sval [my LoadTypedLiteral $value STRING] set itype [lrange $type 1 end] if {$itype in {LIST DICT {EMPTY LIST} {EMPTY DICT}}} { return $sval } set tval [my LoadTypedLiteral $value $itype] return [$b impure $itype $sval $tval] ................................................................................ # None. method StoreResult {desc value {opcode ""}} { upvar 1 phiAnnotations phiAnnotations # Validate that the destination is indeed a variable or temporary if {[lindex $desc 0] ni {"var" "temp"}} { return -code error "cannot store into $desc; it makes no sense" } # Validate that SSA form has been preserved if {[info exists variables($desc)]} { return -code error "Duplicate definition of $desc" } ................................................................................ # Type check the assignment set destType [nameOfType [dict get $vtypes $desc]] if {[Type $destType] ne [TypeOf $value]} { my Warn "Attempt to store the value '%s' into a variable, '%s', of type '%s'" \ [PrintValueToString $value] $desc $destType } if {[lindex $desc 0] eq "var"} { if {[lindex $opcode 0] eq "phi"} { lappend phiAnnotations [lindex $desc 1] $value } else { my AnnotateAssignment [lindex $desc 1] $value } } ................................................................................ # Parameters: # qcval - The quadcode value to extract from. # # Results: # The Tcl value inside the quadcode value. method LiteralValue {qcval} { lassign $qcval key value if {$key ne "literal"} { return -code error "assumption that '$qcval' is literal not met" } return $value } } # Class TclInterproceduralCompiler -- # # This class compiles a single Tcl procedure within the overall |
> > > > > > > > > > > > | | | | | | | | | | | | | > > | | | | | | | | | | | | | > > > | > | | | < > | | | | | | > > | | | | | | | | | | | | | | | | | | | | | | | < | < < < < < < > > > | | | | > | > > > > > > > > > > > > > > > > > > | < > | | | | < > |
37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 .. 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 ... 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 ... 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 ... 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 ... 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 ... 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 ... 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 ... 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 ... 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 ... 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 ... 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 ... 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 ... 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 ... 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 ... 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 ... 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 ... 875 876 877 878 879 880 881 882 883 884 885 886 887 888 889 ... 903 904 905 906 907 908 909 910 911 912 913 914 915 916 917 918 919 920 921 922 923 924 925 926 927 928 929 930 931 932 933 934 935 936 937 938 939 940 941 942 943 944 945 946 947 .... 1196 1197 1198 1199 1200 1201 1202 1203 1204 1205 1206 1207 1208 1209 1210 .... 1311 1312 1313 1314 1315 1316 1317 1318 1319 1320 1321 1322 1323 1324 1325 1326 1327 1328 1329 1330 1331 1332 1333 1334 1335 1336 1337 1338 1339 1340 1341 1342 1343 1344 1345 1346 1347 1348 1349 1350 .... 1376 1377 1378 1379 1380 1381 1382 1383 1384 1385 1386 1387 1388 1389 1390 .... 1404 1405 1406 1407 1408 1409 1410 1411 1412 1413 1414 1415 1416 1417 1418 .... 1524 1525 1526 1527 1528 1529 1530 1531 1532 1533 1534 1535 1536 1537 1538 1539 1540 1541 1542 1543 1544 1545 .... 1556 1557 1558 1559 1560 1561 1562 1563 1564 1565 1566 1567 1568 1569 1570 1571 1572 1573 1574 1575 1576 1577 .... 1604 1605 1606 1607 1608 1609 1610 1611 1612 1613 1614 1615 1616 1617 1618 1619 1620 1621 1622 .... 1738 1739 1740 1741 1742 1743 1744 1745 1746 1747 1748 1749 1750 1751 1752 .... 1875 1876 1877 1878 1879 1880 1881 1882 1883 1884 1885 1886 1887 1888 1889 1890 1891 1892 1893 1894 1895 1896 1897 1898 1899 1900 1901 1902 1903 1904 1905 1906 1907 1908 1909 .... 1979 1980 1981 1982 1983 1984 1985 1986 1987 1988 1989 1990 1991 1992 1993 1994 1995 1996 .... 2005 2006 2007 2008 2009 2010 2011 2012 2013 2014 2015 2016 2017 2018 2019 .... 2056 2057 2058 2059 2060 2061 2062 2063 2064 2065 2066 2067 2068 2069 2070 .... 2072 2073 2074 2075 2076 2077 2078 2079 2080 2081 2082 2083 2084 2085 2086 .... 2264 2265 2266 2267 2268 2269 2270 2271 2272 2273 2274 2275 2276 2277 2278 2279 2280 2281 |
::quadcode::typeOfOperand \ ::quadcode::dataType::mightbea namespace eval tcl { namespace eval mathfunc { proc literal {descriptor} { string equal [lindex $descriptor 0] "literal" } proc var {descriptor} { string equal [lindex $descriptor 0] "var" } proc refType {type} { expr { [uplevel 1 [list my ReferenceType? $type]] && "CALLFRAME" ni $type } } proc failType {type} { ................................................................................ uplevel 1 [list my OperandType $operand] } proc consumed {var search} { uplevel 1 [list my IsConsumed $var $search] } proc callframe {operand} { uplevel 1 [list my IsCallFrame $operand] } proc maybetype {operand type} { uplevel 1 [list my MayBeType $operand $type] } proc impure {type} { expr {"IMPURE" in $type} } } } } # TclCompiler:ByteCode -- # ................................................................................ # # Results: # None. method PrintTypedQuads {channel qs} { set idx -1 set descriptions [lmap q $qs { if {[string match @debug-* [lindex $q 0]]} { concat "[incr idx]:" $q } else { concat "[incr idx]:" $q ":" [linsert [lmap arg [lrange $q 1 end] { try { if {$arg eq ""} { string cat VOID } elseif {[string match {pc *} $arg]} { string cat BLOCK } else { my ValueTypes $arg } } on error {} { string cat VOID } }] 1 "\u21d0"] } }] if {$channel eq ""} { return [format "%s------>\n%s" $cmd [join $descriptions \n]] } else { puts $channel [format "%s------>\n%s" $cmd [join $descriptions \n]] } } ................................................................................ # NB: block(-1) is the function entry block. It's supposed to be # almost entirely optimized out. $block(-1) build-in $b $b @location 0 set errorCode [$b alloc int "tcl.errorCode"] set curr_block $block(-1) set 0 [$b int 0] $b store [Const 0 int] $errorCode ############################################################## # # Create debug info for variables in LLVM dict for {name typecode} $vtypes { lassign $name kind formalname origin set type [nameOfType $typecode] # Make the debugging information for the variable provided it is a # variable as perceived from the Tcl level. "Internal" temporary # variables aren't nearly so interesting. if {var($name)} { if {[lindex $quads $origin 0] eq "param"} { set idx [lsearch $bytecodeVars \ [list "scalar arg" $formalname]] if {$idx < 0} { return -code error \ "unmapped formal variable name: $formalname ($name)" } ................................................................................ my Warn "default injection for parameter %d of '%s'; injecting '%s'" \ [expr {$idx + 1}] [GetValueName [$func ref]] $defaultvalue set var [my LoadTypedLiteral $defaultvalue $type] } else { set var [$func param $idx $name] } set variables($tgt) $var if {impure($type) && "LIST" ni $type && "DICT" ni $type} { set var [$b stringifyImpure $var] set type STRING } if {refType($type)} { $b printref $var "param:" $b addReference($type) $var $b assume [$b shared $var] ................................................................................ "moveToCallFrame" { set mapping [lassign $l opcode tgt src] if {callframe($src)} { foreach {name value} $mapping { set name [lindex $name 1] set var [dict get $thevarmap $name] if {$value ne "Nothing"} { set op frame.store([my OperandType $value]) set value [my LoadOrLiteral $value] $b $op $value $theframe $var $name } else { $b frame.unset $theframe $var $name } } } my StoreResult $tgt [my LoadOrLiteral $src] } "retrieveResult" { lassign $l opcode tgt src if {operandType($src) eq "CALLFRAME"} { set value [$b undef NOTHING] } elseif {callframe($src)} { set value [$b frame.value [my LoadOrLiteral $src]] } else { set value [my LoadOrLiteral $src] my Warn "retrieveResult from non-callframe" } my StoreResult $tgt $value } "extractCallFrame" { lassign $l opcode tgt src if {callframe($src)} { set value [my LoadOrLiteral $src] if {operandType($src) ne "CALLFRAME"} { set name [my LocalVarName $tgt] set value [$b frame.frame $value $name] } } else { set value $theframe } my StoreResult $tgt $value ................................................................................ my StoreResult $tgt \ [$b frame.load $theframe $var $vname $name] } } "result" { lassign $l opcode tgt src set name [my LocalVarName $tgt] append opcode ( [my OperandType $src] ) set src [my LoadOrLiteral $src] my StoreResult $tgt [$b $opcode $src $name] } "returnOptions" { lassign $l opcode tgt src ecode set srcs [lassign $l opcode tgt] set name [my LocalVarName $tgt] ................................................................................ append opcode ( [my ValueTypes {*}$srcs] ) set srcs [lmap s $srcs {my LoadOrLiteral $s}] my StoreResult $tgt [$b $opcode {*}$srcs $name] } "nsupvar" - "upvar" - "variable" { set srcs [lassign $l opcode tgt src] set localvar [lindex $srcs 0] if {!literal($localvar)} { error "local variable must be literal" } set name [my LocalVarName $tgt] set var [dict get $thevarmap [lindex $localvar 1]] set op [dict get { nsupvar frame.bind.nsvar upvar frame.bind.upvar variable frame.bind.var } $opcode] append op ( [my ValueTypes {*}$srcs] ) set srcs [lmap s $srcs {my LoadOrLiteral $s}] set res [$b $op {*}$srcs $var $theframe $errorCode $name] if {"FAIL" in operandType($tgt)} { my SetErrorLine $errorCode \ [$b maybe [$b frame.value $res]] } my StoreResult $tgt $res } "bitor" - "bitxor" - "bitand" - "lshift" - "rshift" - "add" - "sub" - "mult" - "uminus" - "uplus" - "land" - "lor" - ................................................................................ } "originCmd" { set srcs [lassign $l opcode tgt] set name [my LocalVarName $tgt] append opcode ( [my ValueTypes {*}$srcs] ) set srcs [lmap s $srcs {my LoadOrLiteral $s}] set res [$b $opcode {*}$srcs $errorCode $name] if {"FAIL" in operandType($tgt)} { my SetErrorLine $errorCode [$b maybe $res] } my StoreResult $tgt $res } "list" { set srcs [lassign $l opcode tgt] set name [my LocalVarName $tgt] ................................................................................ my StoreResult $tgt [$b list $objv $srcs $types $name] } "strindex" { set srcs [lassign $l opcode tgt] set name [my LocalVarName $tgt] set srcs [my ConvertIndices 0 strlen 1] set res [$b $opcode {*}$srcs $errorCode $name] if {"FAIL" in operandType($tgt)} { my SetErrorLine $errorCode [$b maybe $res] } my StoreResult $tgt $res } "strrange" - "strreplace" { set srcs [lassign $l opcode tgt] set name [my LocalVarName $tgt] set srcs [my ConvertIndices 0 strlen 1 2] set res [$b $opcode {*}$srcs $errorCode $name] if {"FAIL" in operandType($tgt)} { my SetErrorLine $errorCode [$b maybe $res] } my StoreResult $tgt $res } "directGet" - "directSet" - "directAppend" - "directLappend" - "directLappendList" - "directUnset" - "directArrayGet" - "directArraySet" - "directArrayAppend" - ................................................................................ "dictAppend" - "dictIncr" - "dictLappend" - "dictSize" - "div" - "expon" - "mod" - "verifyList" - "dictGetOrNexist" - "dictSetOrUnset" { set srcs [lassign $l opcode tgt] set name [my LocalVarName $tgt] append opcode ( [my ValueTypes {*}$srcs] ) set srcs [lmap s $srcs {my LoadOrLiteral $s}] if {"FAIL" in operandType($tgt)} { set res [$b $opcode {*}$srcs $errorCode $name] my SetErrorLine $errorCode [$b maybe $res] } else { set res [$b $opcode {*}$srcs $name] } my StoreResult $tgt $res } "listAppend" - "listConcat" - "listRange" { set srcs [lassign $l opcode tgt] set src1 [lindex $srcs 0] set name [my LocalVarName $tgt] append opcode ( [my ValueTypes {*}$srcs] ) set srcs [lmap s $srcs {my LoadOrLiteral $s}] set canFail [expr {"FAIL" in operandType($tgt)}] set ec [if {$canFail} {list $errorCode}] if {consumed($src1, $pc + 1)} { $b printref $value "[lindex $l 0 0]:A:" set res [$b $opcode {*}$srcs {*}$ec $name] } else { $b printref $value "[lindex $l 0 0]:B:" $b addReference([my OperandType $src1]) [lindex $srcs 0] set res [$b $opcode {*}$srcs {*}$ec $name] $b dropReference([my OperandType $src1]) [lindex $srcs 0] } if {$canFail} { my SetErrorLine $errorCode [$b maybe $res] } my StoreResult $tgt $res } "returnCode" { lassign $l opcode tgt src set name [my LocalVarName $tgt] append opcode ( [my OperandType $src] ) my StoreResult $tgt \ [$b $opcode [my LoadOrLiteral $src] \ [$b load $errorCode] $name] } "initException" { my IssueException $l } "setReturnCode" { lassign $l opcode tgt src append opcode ( [my OperandType $src] ) my StoreResult $tgt \ [$b $opcode [my LoadOrLiteral $src] $errorCode] } "procLeave" { set srcs [lassign $l opcode tgt] set name [my LocalVarName $tgt] append opcode ( [my ValueTypes {*}$srcs] ) ................................................................................ set srcs [list $srcObj {*}$srcs] append opcode ( [my ValueTypes {*}$srcs] ) set srcs [lmap s $srcs {my LoadOrLiteral $s}] set res [$b $opcode {*}$srcs $errorCode $name] my StoreResult $tgt $res } else { # Need to construct the variadic path set vectortypes [lmap s $srcs {my OperandType $s}] set vector [$b buildVector $objv $vectortypes \ [lmap s $srcs {my LoadOrLiteral $s}]] append opcode ( [my OperandType $srcObj] ) set srcObj [my LoadOrLiteral $srcObj] set res [$b $opcode $srcObj $vector $errorCode $name] my StoreResult $tgt $res $b clearVector $vector } if {"FAIL" in operandType($tgt)} { my SetErrorLine $errorCode [$b maybe $res] } } "dictSet" { set srcs [lassign $l opcode tgt srcObj srcValue] set name [my LocalVarName $tgt] if {[llength $srcs] == 1} { ................................................................................ set srcs [list $srcObj {*}$srcs $srcValue] append opcode ( [my ValueTypes {*}$srcs] ) set srcs [lmap s $srcs {my LoadOrLiteral $s}] set res [$b $opcode {*}$srcs $name] my StoreResult $tgt $res } else { # Need to construct the variadic path set vectortypes [lmap s $srcs {my OperandType $s}] set vector [$b buildVector $objv $vectortypes \ [lmap s $srcs {my LoadOrLiteral $s}]] set srcs [list $srcObj $srcValue] append opcode ( [my ValueTypes {*}$srcs] ) set srcs [lmap s $srcs {my LoadOrLiteral $s}] set res [$b $opcode {*}$srcs $vector $errorCode $name] my StoreResult $tgt $res $b clearVector $vector } if {"FAIL" in operandType($tgt)} { my SetErrorLine $errorCode [$b maybe $res] } } "listSet" { set srcs [lassign $l opcode tgt srcObj srcValue] set name [my LocalVarName $tgt] if {[llength $srcs] == 1} { ................................................................................ set srcs [list $srcObj {*}$srcs $srcValue] append opcode ( [my ValueTypes {*}$srcs] ) set srcs [lmap s $srcs {my LoadOrLiteral $s}] set res [$b $opcode {*}$srcs $errorCode $name] my StoreResult $tgt $res } else { # Need to construct the variadic path set vectortypes [lmap s $srcs {my OperandType $s}] set vector [$b buildVector $objv $vectortypes \ [lmap s $srcs {my LoadOrLiteral $s}]] set srcs [list $srcObj $srcValue] append opcode ( [my ValueTypes {*}$srcs] ) set srcs [lmap s $srcs {my LoadOrLiteral $s}] set res [$b $opcode {*}$srcs $vector $errorCode $name] my StoreResult $tgt $res $b clearVector $vector } if {"FAIL" in operandType($tgt)} { my SetErrorLine $errorCode [$b maybe $res] } } "copy" - "expand" { lassign $l opcode tgt src set value [my LoadOrLiteral $src] set type [my OperandType $tgt] ................................................................................ my StoreResult $tgt $value } "maptoint" { lassign $l opcode tgt src map def set map [lindex $map 1] set def [lindex $def 1] set name [my LocalVarName $tgt] append opcode ( [my OperandType $src] ) set src [my LoadOrLiteral $src] my StoreResult $tgt [$b $opcode $src $map $def $name] } "extractExists" - "extractMaybe" { my IssueExtract $l } "extractFail" { lassign $l opcode tgt src set name [my LocalVarName $tgt] append opcode ( [my OperandType $src] ) set src [my LoadOrLiteral $src] my StoreResult $tgt [$b $opcode $src $name] } "purify" { lassign $l opcode tgt src set value [my LoadOrLiteral $src] set srctype [my OperandType $src] if {!impure($srctype)} { return -code error \ "Trying to purify something that is not impure" } set name [my LocalVarName $tgt] if {"LIST" ni $srctype && "DICT" ni $srctype} { set value [$b impure.value $value $name] } ................................................................................ lassign $l opcode tgt src set type [my OperandType $src] if {$src ni $consumed} { if {$type eq "VOID"} { # VOID is trivial to free } elseif {refType($type)} { $b printref $variables($src) "free:" set vt [my OperandType $src] if {"ARRAY" in $vt} { # TRICKY POINT: need variable name to unset an array set name [Const [my LocalVarName $tgt] STRING] $b dropReference($vt) $variables($src) $name } else { $b dropReference($vt) $variables($src) } ................................................................................ $b br $block($tgt) } } "jumpTrue" { lassign $l opcode tgt src set name [my LocalVarName $src] set tgt [lindex $tgt 1] set mth isTrue([my OperandType $src]) set test [$b $mth [my LoadOrLiteral $src] test_$name] $b condBr $test $block($tgt) $ipath($pc) } "jumpFalse" { lassign $l opcode tgt src set name [my LocalVarName $src] set tgt [lindex $tgt 1] set mth isTrue([my OperandType $src]) set test [$b $mth [my LoadOrLiteral $src] test_$name] $b condBr $test $ipath($pc) $block($tgt) } "jump" { $b br $block([lindex $l 1 1]) } "return" { lassign $l opcode -> frame src set val [my LoadOrLiteral $src] if {callframe($src)} { # The CALLFRAME does not leave set val [$b frame.value $val] } set type [nameOfType $returnType] if {refType($type)} { $b printref $val "ret:" if {literal($src)} { ................................................................................ } } } "frameArgs" { lassign $l opcode tgt src set name [my LocalVarName $tgt] set opcode frame.args append opcode ( [my OperandType $src] ) set val [my LoadOrLiteral $src] set result [$b $opcode $val $theframe $name] my StoreResult $tgt $result } "frameDepth" { lassign $l opcode tgt set name [my LocalVarName $tgt] ................................................................................ lappend consumed $src1 } else { set result [$b unshareCopy($type) $val $name] } $b printref $result "cat:" foreach src $srcs { set val [my LoadOrLiteral $src] $b appendString([my OperandType $src]) $val $result } my StoreResult $tgt $result } "concat" { set srcs [lassign $l opcode tgt] # Need to construct the variadic vector set vectortypes [lmap s $srcs {my OperandType $s}] set vector [$b buildVector $objv $vectortypes \ [lmap s $srcs {my LoadOrLiteral $s}]] set name [my LocalVarName $tgt] set result [$b concat() $vector $name] my StoreResult $tgt $result $b clearVector $vector } "foreachStart" { set srcs [lassign $l opcode tgt assign] set listtypes [lmap s $srcs {my OperandType $s}] set lists [lmap s $srcs {my LoadOrLiteral $s}] set result [$b foreachStart \ [lindex $assign 1] $lists \ $listtypes $errorCode] if {"FAIL" in operandType($tgt)} { my SetErrorLine $errorCode [$b maybe $result] } my StoreResult $tgt $result } "unshareList" { lassign $l opcode tgt src set name [my LocalVarName $tgt] append opcode ( [my OperandType $src] ) set result [$b $opcode [my LoadOrLiteral $src] $name] my StoreResult $tgt $result } "foreachIter" - "foreachAdvance" - "foreachMayStep" - "dictIterKey" - "dictIterValue" - "dictIterDone" - "dictIterNext" { lassign $l opcode tgt src ................................................................................ set varmeta [dict get $bytecode variables] set argtypes {STRING} set arguments [list [list literal $cmd]] foreach vinfo $varmeta { if {"arg" in [lindex $vinfo 0]} { set vname [list var [lindex $vinfo 1] [llength $arguments]] lappend arguments $vname lappend argtypes [my OperandType $vname] } } # Patch in the extra variables discovered during quadcode analysis; # these are never arguments as Tcl always correctly puts those in the # original bytecode descriptor. set stdnames [lmap vinfo $varmeta {lindex $vinfo 1}] ................................................................................ } method IssueInvokeFunction {tgt func arguments vname} { upvar 1 callframe callframe thecallframe thecallframe set BASETYPES {ZEROONE INT DOUBLE NUMERIC STRING} set result [$b call $func $arguments $vname] if {operandType($tgt) eq "FAIL"} { $b store $result $errorCode my SetErrorLine $errorCode } else { set ts [lmap t $BASETYPES {Type $t?}] if {[TypeOf $result] in $ts} { $b store [$b extract $result 0] $errorCode } elseif {[Type [TypeOf $result]?] eq [Type [my OperandType $tgt]]} { # Managed to prove non-failure in this case... set result [$b ok $result] } if {"FAIL" in operandType($tgt)} { my SetErrorLine $errorCode [$b maybe $result] } } if {callframe($thecallframe)} { set result [$b frame.pack $callframe $result] } my StoreResult $tgt $result } method IssueInvokeCommand {tgt resolved arguments argvals vname} { upvar 1 callframe callframe thecallframe thecallframe set types [lmap s $arguments {my OperandType $s}] if {$resolved ne ""} { # FIXME: this causes wrong "wrong # args" messages set argvals [lreplace $argvals 0 0 $resolved] } set vector [$b buildVector $objv $types $argvals] set result [$b invoke $vector \ [expr {callframe($thecallframe)}] $callframe \ ................................................................................ method IssueInvokeExpanded {callframe operation} { set arguments [lassign $operation opcode tgt thecallframe] set vname [my LocalVarName $tgt] set expandPositions [lmap s $arguments { expr {"EXPANDED" in [my OperandType $s]} }] set argvals [lmap s $arguments {my LoadOrLiteral $s}] set types [lmap s $arguments {my OperandType $s}] set vector [$b buildVector $objv $types $argvals] set flags [$b buildBitArray $bitv $expandPositions] set result [$b invokeExpanded $vector $flags $errorCode $vname] my SetErrorLine $errorCode [$b maybe $result] if {callframe($thecallframe)} { set result [$b frame.pack $callframe $result] } ................................................................................ # # Results: # none method IssueWiden {operation} { lassign $operation opcode tgt src set name [my LocalVarName $tgt] set srctype [my OperandType $src] set tgttype [lindex $opcode 2] if {$tgttype eq ""} { set tgttype [my OperandType $tgt] } if {$srctype in {"VOID" "NOTHING" "NEXIST"}} { switch -glob -- $tgttype { "FAIL *" { ................................................................................ if {"STRING" in $tgttype && ("LIST" in $srctype || "DICT" in $srctype)} { return $value } # IMPURE to IMPURE - Copy the string value, and promote the # inner value if {impure($tgttype) && impure($srctype)} { set itgttype [lrange $tgttype 1 end] set isrctype [lrange $srctype 1 end] set ivalue [my WidenedValue [$b impure.value $value] \ $isrctype $itgttype] set svalue [$b impure.string $value] set value [$b impure $itgttype $svalue $ivalue $name] } elseif {impure($srctype) && "STRING" in $tgttype} { set value [$b stringifyImpure $value $name] } elseif {[regexp {^IMPURE (.*)$} $tgttype -> innertype]} { set widened [my WidenedValue $value $srctype $innertype] set value [$b packImpure($innertype) $widened $name] } elseif {$tgttype eq "ZEROONE BOOLEAN"} { if {$srctype in {"ZEROONE" "BOOLEAN"}} { # do nothing - the internal reps are the same ................................................................................ if {$srctype eq "DOUBLE"} { set value [$b packNumericDouble $value $name] } else { set value [$b packNumericInt $value $name] } } elseif {$srctype eq "EMPTY" && $tgttype eq "STRING"} { set value [Const "" STRING] } if {[Type $tgttype] eq [Type [TypeOf $value]?]} { set value [$b ok $value] } elseif {[Type $tgttype] eq [Type [TypeOf $value]!]} { set value [$b just $value] } elseif {[Type $srctype] ne [Type $tgttype]} { # If the types didn't end up matching, we're in deep trouble now... my Warn "unimplemented convert from '%s' to '%s'" $srctype $tgttype } return $value } # TclCompiler:IssueDictExists -- # # Generate the code for testing whether an element of a dictionary ................................................................................ return } elseif {[llength $srcs] == 0 && $srcDict eq "literal \uf8ff"} { my StoreResult $tgt [my LoadOrLiteral "literal 0"] return } # Need to construct the variadic vector set types [lmap s $srcs {my OperandType $s}] set vector [$b buildVector $objv $types \ [lmap s $srcs {my LoadOrLiteral $s}]] set name [my LocalVarName $tgt] append opcode ( [my OperandType $srcDict] ) set srcDict [my LoadOrLiteral $srcDict] my StoreResult $tgt [$b $opcode $srcDict $vector $name] $b clearVector $vector return } # TclCompiler:IssueExtract -- ................................................................................ # Results: # none method IssueException {operation} { upvar 1 errorCode errorCode set srcs [lassign $operation opcode tgt src] set src2 [lindex $srcs 0] set maintype [my OperandType $src] set name [my LocalVarName $tgt] append opcode ( [my ValueTypes {*}$srcs] ) set value [my LoadOrLiteral $src] # Check if we can issue more efficient code by understanding the # literals provided (if everything is non-literal, we can't do much). if {[llength $srcs] == 3 && literal($src2)} { ................................................................................ # # Results: # A Tcl boolean value. method IsCallFrame {operand} { variable ::quadcode::dataType::CALLFRAME return [expr { !literal($operand) && ([typeOfOperand $vtypes $operand] & $CALLFRAME) != 0 }] } # TclCompiler:MayBeBasicType -- # # Get whether a particular operand may be of a particular type. # # Parameters: # operand - # The operand to test the type of. # type - The name of the type (see quadcode/types.tcl) # # Results: # A Tcl boolean value. method MayBeBasicType {operand type} { namespace upvar ::quadcode::dataType $type typecode return [expr {([typeOfOperand $vtypes $operand] & $typecode) != 0}] } # TclCompiler:ValueTypes -- # # Convert the sequence of arguments (to an opcode) into the type # signature tuple to use with the name of the method in the Build class # to enable automatic type widening. ................................................................................ if {[info exist variables($desc)]} { return $variables($desc) } if {$desc eq "Nothing"} { # NEXIST special case return "Nothing" } if {!literal($desc)} { return -code error "unsubstitutable argument: $desc" } lassign $desc -> value set type [nameOfType [typeOfLiteral $value]] return [my LoadTypedLiteral $value $type] } # TclCompiler:LoadTypedLiteral -- # # Generate the code to create a LLVM value reference, given the ................................................................................ # # Maintainer note: # DO NOT do reference count management in this function! It makes things # leak or triggers use-after-free crashes. Leave that to the main # compiler engine (and the STRING allocator) as that gets it right. method LoadTypedLiteral {value type} { if {impure($type)} { set sval [my LoadTypedLiteral $value STRING] set itype [lrange $type 1 end] if {$itype in {LIST DICT {EMPTY LIST} {EMPTY DICT}}} { return $sval } set tval [my LoadTypedLiteral $value $itype] return [$b impure $itype $sval $tval] ................................................................................ # None. method StoreResult {desc value {opcode ""}} { upvar 1 phiAnnotations phiAnnotations # Validate that the destination is indeed a variable or temporary if {literal($desc)} { return -code error "cannot store into $desc; it makes no sense" } # Validate that SSA form has been preserved if {[info exists variables($desc)]} { return -code error "Duplicate definition of $desc" } ................................................................................ # Type check the assignment set destType [nameOfType [dict get $vtypes $desc]] if {[Type $destType] ne [TypeOf $value]} { my Warn "Attempt to store the value '%s' into a variable, '%s', of type '%s'" \ [PrintValueToString $value] $desc $destType } if {var($desc)} { if {[lindex $opcode 0] eq "phi"} { lappend phiAnnotations [lindex $desc 1] $value } else { my AnnotateAssignment [lindex $desc 1] $value } } ................................................................................ # Parameters: # qcval - The quadcode value to extract from. # # Results: # The Tcl value inside the quadcode value. method LiteralValue {qcval} { if {!literal($qcval)} { return -code error "assumption that '$qcval' is literal not met" } lassign $qcval -> value return $value } } # Class TclInterproceduralCompiler -- # # This class compiles a single Tcl procedure within the overall |
Changes to codegen/stdlib.tcl.
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
...
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
|
# Increment the reference count of a Tcl_Obj reference if the
# object is supplied
set f [$m local "tcl.addFailReference" void<-Tcl_Obj*?]
params value:maybeObjPtr
build {
my condBr [my maybe $value] $nothing $incr
label incr "action.required"
set value [my unmaybe $value "objPtr"]
$api Tcl_IncrRefCount $value
my ret
label nothing "nothing.to.do"
my ret
}
................................................................................
my ret
label gotNull "got.null"
set str [$api Tcl_ObjPrintf [my constString "%d:NULL\n"] $pr]
$api Tcl_WriteObj $chan $str
$api Tcl_DecrRefCount $str
my ret
}
set f [$m local writeref? void<-int,STRING?,char*]
params pr val prefix
build {
my condBr [my maybe $val] $done $print
label print:
my Call writeref $pr [my unmaybe $val] $prefix
my ret
label done:
my ret
}
set f [$m local writearef void<-int,ARRAY,char*]
params pr val prefix
build {
nonnull $val
set chan [$api Tcl_GetStdChannel [Const [expr 1<<3]]]
my condBr [my nonnull $prefix] $printPrefix $printRef
label printPrefix "print.prefix"
set str [$api Tcl_NewStringObj $prefix [Const -1]]
|
|
|
|
|
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
...
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
|
# Increment the reference count of a Tcl_Obj reference if the # object is supplied set f [$m local "tcl.addFailReference" void<-Tcl_Obj*?] params value:maybeObjPtr build { my condBr [my maybe $value] $nothing $incr label incr "action.required.afr" set value [my unmaybe $value "objPtr"] $api Tcl_IncrRefCount $value my ret label nothing "nothing.to.do" my ret } ................................................................................ my ret label gotNull "got.null" set str [$api Tcl_ObjPrintf [my constString "%d:NULL\n"] $pr] $api Tcl_WriteObj $chan $str $api Tcl_DecrRefCount $str my ret } set f [$m local writeref? void<-int,STRING?,char* noinline] params pr val prefix build { my condBr [my maybe $val] $done $print label print: my Call writeref $pr [my unmaybe $val] $prefix my ret label done: my ret } set f [$m local writearef void<-int,ARRAY,char* noinline] params pr val prefix build { nonnull $val set chan [$api Tcl_GetStdChannel [Const [expr 1<<3]]] my condBr [my nonnull $prefix] $printPrefix $printRef label printPrefix "print.prefix" set str [$api Tcl_NewStringObj $prefix [Const -1]] |
Changes to quadcode/types.tcl.
363 364 365 366 367 368 369 370 371 372 373 374 375 376 ... 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 ... 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 ... 978 979 980 981 982 983 984 985 986 987 988 989 990 991 992 |
FAIL FAIL ARRAY ARRAY DICTITER DICTITER FOREACH FOREACH EXPANDED EXPANDED OTHERSTRING STRING IMPURE IMPURE EMPTY EMPTY } { namespace upvar dataType $name t if {$type & $t} { namespace upvar dataType $wname w lappend result $wname set type [expr {$type & ~$w}] ................................................................................ foreach {name wname} { DOUBLE DOUBLE BIGINT ENTIER OTHERINT64 INT OTHERINT32 INT ZEROONE ZEROONE BOOLWORD BOOLEAN NONDICTLIST LIST NONEMPTYDICT DICT DICT DICT LIST LIST } { namespace upvar dataType $name t if {$type & $t} { namespace upvar dataType $wname w lappend result $wname set type [expr {$type & ~$w}] } ................................................................................ if {(istype($t1, $INT) || istype($t1, $ZEROONE)) && (istype($t2, $INT) || istype($t2, $ZEROONE))} { return $LIST } return [expr {$LIST | $FAIL}] } listSet { puts [format "DEBUG: %s : %s" [lindex $q 0] [lmap arg [lrange $q 2 end] {nameOfType [typeOfOperand $types $arg]}]] return [expr {$LIST | $FAIL}] } strindex - strrange - strreplace - dictGet { return [expr {$STRING | $FAIL}] } dictSetOrUnset - dictAppend { return $DICT ................................................................................ # We claim that lists of length one are simple STRINGs; that's usually # a more honest choice. if {[llength $x] <= 1} { return $dataType::IMPUREOTHERSTRING } # Odd-length LISTs cannot be DICTs, and we prefer to not call them # DICTs if they have non-unique keys. if {[llength $x] & 1 == 0 && [dict create {*}$x] eq [list {*}$x]} { return $dataType::NONEMPTYDICT } else { return $dataType::NONDICTLIST } } else { return $dataType::IMPUREOTHERSTRING } |
> > < < < < < | |
363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 ... 387 388 389 390 391 392 393 394 395 396 397 398 399 400 ... 774 775 776 777 778 779 780 781 782 783 784 785 786 787 ... 975 976 977 978 979 980 981 982 983 984 985 986 987 988 989 |
FAIL FAIL ARRAY ARRAY DICTITER DICTITER FOREACH FOREACH EXPANDED EXPANDED OTHERSTRING STRING IMPURE IMPURE NONDICTLIST LIST NONEMPTYDICT DICT EMPTY EMPTY } { namespace upvar dataType $name t if {$type & $t} { namespace upvar dataType $wname w lappend result $wname set type [expr {$type & ~$w}] ................................................................................ foreach {name wname} { DOUBLE DOUBLE BIGINT ENTIER OTHERINT64 INT OTHERINT32 INT ZEROONE ZEROONE BOOLWORD BOOLEAN } { namespace upvar dataType $name t if {$type & $t} { namespace upvar dataType $wname w lappend result $wname set type [expr {$type & ~$w}] } ................................................................................ if {(istype($t1, $INT) || istype($t1, $ZEROONE)) && (istype($t2, $INT) || istype($t2, $ZEROONE))} { return $LIST } return [expr {$LIST | $FAIL}] } listSet { return [expr {$LIST | $FAIL}] } strindex - strrange - strreplace - dictGet { return [expr {$STRING | $FAIL}] } dictSetOrUnset - dictAppend { return $DICT ................................................................................ # We claim that lists of length one are simple STRINGs; that's usually # a more honest choice. if {[llength $x] <= 1} { return $dataType::IMPUREOTHERSTRING } # Odd-length LISTs cannot be DICTs, and we prefer to not call them # DICTs if they have non-unique keys. if {([llength $x] & 1) == 0 && [dict create {*}$x] eq $x} { return $dataType::NONEMPTYDICT } else { return $dataType::NONDICTLIST } } else { return $dataType::IMPUREOTHERSTRING } |