Changes to codegen/build.tcl.
︙ | | |
9
10
11
12
13
14
15
16
17
18
19
20
21
22
|
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
|
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
|
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
#------------------------------------------------------------------------------
oo::define Builder {
# Builder:Tcl_Alloc --
#
# Allocate memory using Tcl's system
#
# Parameters:
# size - An LLVM value reference giving the size of the block to allocated
# name - The name to give to the value
#
# Results:
# Returns an LLVM value reference designating the pointer to the allocated
# block
method Tcl_Alloc {size {name {}}} {
my call ${tcl.alloc} [list $size] $name
}
export Tcl_Alloc
# Builder:Tcl_Free --
#
# Free memory using Tcl's system
#
# Parameters:
# block - An LLVM value reference giving the pointer to the block
method Tcl_Free {block} {
my call ${tcl.free} [list $block]
}
export Tcl_Free
# Builder:isInt32 --
#
# Generate code to test if an INT holds an int32.
#
# Parameters:
# INT - The INT LLVM value reference.
# name (optional) -
|
︙ | | |
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
|
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
|
+
+
+
-
+
+
-
-
+
|
# argc - The int LLVM value reference for the number of arguments.
# argv - The STRING* LLVM value reference (or equivalent type) for the
# array of arguments, allocated on the function stack.
# proc - The LLVM value reference to the procedure's metadata.
# localcache -
# The LLVM value reference to the procedure's local variable
# metadata.
# callframe - The LLVM pointer reference to the callframe to construct
# entryBlock - The entry block of the function, needed for allocating
# the array of local variables.
#
# Results:
# A Tcl list of the LLVM CALLFRAME value reference and the mapping
# dictionary from string variable names to the corresponding LLVM Var*
# value references.
method frame.create {varlist argc argv proc localcache} {
method frame.create {varlist argc argv proc localcache callframe
entryBlock} {
# Construct the call frame itself
set callframe [my alloc CallFrame "callframe"]
set length [Const [llength $varlist]]
set locals [my arrayAlloc Var $length]
set locals [my arrayAllocInBlock $entryBlock Var $length]
my Call tcl.callframe.init $callframe $length \
$argc [my cast(ptr) $argv STRING] $proc $localcache $locals
# Initialise the information about the local variables
set idx -1
set varmap {}
foreach varinfo $varlist {
lassign $varinfo flags var
|
︙ | | |
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
|
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
|
-
+
-
+
+
|
# The CALLFRAME LLVM value reference.
# ec - An int* LLVM reference for where to write error codes into.
# name (optional) -
# The LLVM name of the result value.
#
# Results:
# An LLVM bool? value reference.
method frame.bind.upvar(STRING,STRING,STRING) {
localName level otherName localVar callframe ec {name ""}} {
localName level otherName localVar callframe ec {name ""}
} {
set otherVar [my call ${tcl.callframe.lookup.upvar} [list \
$callframe $level $otherName] "otherVar"]
set val [my call ${tcl.callframe.bindvar} [list \
$callframe $otherVar $localVar $localName $ec] $name]
return [my frame.pack $callframe $val $name]
}
|
︙ | | |
1228
1229
1230
1231
1232
1233
1234
1235
1236
1237
1238
1239
1240
1241
1242
1243
1244
1245
1246
1247
1248
1249
1250
1251
1252
1253
1254
1255
1256
1257
1258
1259
1260
1261
1262
1263
1264
1265
1266
1267
1268
1269
1270
1271
1272
1273
|
1262
1263
1264
1265
1266
1267
1268
1269
1270
1271
1272
1273
1274
1275
1276
1277
1278
1279
1280
1281
1282
1283
1284
1285
1286
1287
1288
1289
1290
1291
1292
1293
1294
1295
1296
1297
1298
1299
1300
1301
1302
1303
1304
1305
1306
1307
1308
1309
1310
1311
|
+
+
-
+
-
+
+
+
-
+
-
+
|
}
# Builder:allocBitv --
#
# Allocate a bit vector of a given length.
#
# Parameters:
# entryBlock - The block in which the 'alloca' should appear
# len - The length of the vector
# name (optional) - Name to give to the resulting LLVM value
#
# Results:
# Returns an LLVM int1* reference designating the start of the vector
#
# MUST BE CALLED WHILE EMITTING CODE FOR THE ENTRY BLOCK AND AT
# NO OTHER TIME
method allocBitv {len {name {}}} {
method allocBitv {entryBlock len {name {}}} {
set type [Type array{bool,$len}]
set bits [my alloc $type ${name}.space]
set bits [my allocInBlock $entryBlock $type ${name}.space]
set first [my gep $bits 0]
SetValueName $first $name
return $first
}
# Builder:allocObjv --
#
# Allocate a STRING vector of a given length
#
# Parameters:
# entryBlock - The block in which the 'alloca' should appear
# len - The length of the vector
# name (optional) - Name to give to the resulting LLVM value
#
# Results:
# Returns an LLVM STRING* reference designating the start of the vector
#
# MUST BE CALLED WHILE EMITTING CODE FOR THE ENTRY BLOCK AND AT
# NO OTHER TIME
method allocObjv {len {name {}}} {
method allocObjv {entryBlock len {name {}}} {
set type [Type array{STRING,$len}]
set strs [my alloc $type ${name}.space]
set strs [my allocInBlock $entryBlock $type ${name}.space]
set first [my gep $strs 0]
SetValueName $first $name
return $first
}
# Builder:appendString --
#
|
︙ | | |
1763
1764
1765
1766
1767
1768
1769
1770
1771
1772
1773
1774
1775
1776
1777
1778
1779
1780
1781
1782
1783
1784
1785
1786
1787
1788
1789
1790
1791
1792
1793
1794
1795
1796
1797
|
1801
1802
1803
1804
1805
1806
1807
1808
1809
1810
1811
1812
1813
1814
1815
1816
1817
1818
1819
1820
1821
1822
1823
1824
1825
1826
1827
1828
1829
1830
1831
1832
1833
1834
1835
|
-
-
+
+
-
+
-
+
-
-
+
+
-
+
|
# as where a multi-element dictionary path is required. This value
# *MUST* be cleaned up after use with clearVector.
#
# Parameters:
# start - An LLVM STRING* value that designates the start of the vecotr
# types - The types of the values used to build the vector, as a Tcl
# list of type descriptors.
# values -
# Tcl list of LLVM value references that are the individual
# qvalues -
# Tcl list of quadcode values that are the individual
# elements of the vector.
#
# lvalues - Tcl list of LLVM values of the individual elements
# Results:
# LLVM vector value reference.
method buildVector {start types values} {
method buildVector {start types qvalues lvalues} {
# Implementation note: there must be no branches in the issued code.
set vectortype [Type struct{int,STRING*}]
set idx -1
foreach src $values t $types {
set s [my stringify($t) $src]
foreach src $qvalues t $types v $lvalues {
set s [my stringify($t) $v]
set cell [my gep $start 0 [incr idx]]
my store $s $cell
if {![my IsVectorItemConstant $src $t]} {
my addReference(STRING) $s
}
}
set vector [my undef $vectortype]
set vector [my insert $vector [Const [llength $values]] 0]
set vector [my insert $vector [Const [llength $lvalues]] 0]
set vector [my insert $vector [my gep $start 0 0] 1]
return $vector
}
# Builder:ExtractVector --
#
# Extract the length and array of STRINGs from a vector.
|
︙ | | |
2092
2093
2094
2095
2096
2097
2098
2099
2100
2101
2102
2103
2104
2105
2106
2107
2108
2109
2110
2111
2112
2113
2114
|
2130
2131
2132
2133
2134
2135
2136
2137
2138
2139
2140
2141
2142
2143
2144
2145
2146
2147
2148
2149
2150
2151
2152
2153
2154
2155
2156
2157
2158
2159
2160
2161
2162
2163
|
-
-
+
+
+
+
+
+
-
+
+
-
-
+
+
+
+
+
+
+
+
|
}
# Builder:clearVector --
#
# Clean up a vector value created with buildVector.
#
# Parameters:
# vector -
# The LLVM vector value reference.
# objv - The start of the vector to be cleared
# srcs - The quadcode values that the vector elements were built from.
# Used to detect direct literal STRINGs, which don't need
# free-ing.
# types - The types of the values used to build the vector.
#
# Results:
# None.
method clearVector {vector} {
method clearVector {objv types srcs} {
set idx -1
foreach src $srcs t $types {
my ExtractVector $vector objc objv
my call ${tcl.vector.clear} [list $objc $objv]
incr idx
if {![my IsVectorItemConstant $src $t]} {
set ptr [my gep $objv 0 $idx]
set toDrop [my load $ptr]
my dropReference [my load [my gep $objv 0 $idx]]
}
}
return
}
# Builder:concat() --
#
# Concatenate a collection of values using the classic Tcl algorithm.
# Quadcode implementation ('concat').
|
︙ | | |
4444
4445
4446
4447
4448
4449
4450
4451
4452
4453
4454
4455
4456
4457
4458
4459
4460
4461
4462
4463
4464
4465
4466
4467
4468
4469
4470
4471
4472
4473
4474
4475
4476
4477
4478
4479
4480
4481
4482
4483
4484
4485
4486
4487
4488
4489
4490
4491
4492
4493
4494
4495
4496
4497
4498
4499
4500
|
4493
4494
4495
4496
4497
4498
4499
4500
4501
4502
4503
4504
4505
4506
4507
4508
4509
4510
4511
4512
4513
4514
4515
4516
4517
4518
4519
4520
4521
4522
4523
4524
4525
4526
4527
4528
4529
4530
4531
4532
4533
4534
4535
4536
4537
4538
4539
4540
4541
4542
4543
4544
4545
4546
4547
4548
4549
4550
4551
4552
4553
4554
4555
4556
4557
4558
4559
4560
4561
4562
4563
4564
4565
4566
4567
4568
4569
4570
4571
4572
4573
4574
4575
4576
4577
4578
4579
4580
4581
4582
4583
4584
4585
4586
4587
4588
4589
4590
4591
4592
4593
4594
4595
4596
4597
4598
4599
4600
4601
4602
4603
4604
4605
4606
4607
4608
4609
4610
4611
|
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
|
# Builder:invoke --
#
# Generate code to call a Tcl command. Quadcode implementation
# ('invoke').
#
# Parameters:
# arguments -
# The arguments as an LLVM vector value reference. Note that
# The arguments as an LLVM array value reference. Note that
# this includes the function name as the first argument.
# havecf -
# Tcl boolean indicating if we have a valid callframe.
# cf - The reference to the current callframe if 'havecf' is true.
# ec - Location to write the Tcl return code into, as an LLVM int*
# reference.
# resultName (optional) -
# A name to give to the result value.
#
# Results:
# An LLVM value reference.
method invoke {arguments havecf cf ec {resultName ""}} {
my ExtractVector $arguments
if {!$havecf} {
set cf {}
}
my call ${tcl.invoke.command} [list $len $ary $cf $ec] $resultName
}
# Builder:invokeNRE --
#
# Generate code to call a Tcl command with non-recursive eval.
# Quadcode implementation ('NRE.invoke').
#
# Parameters:
# arguments -
# The arguments as an LLVM array value reference. Note that
# this includes the function name as the first argument.
# havecf -
# Tcl boolean indicating if we have a valid callframe.
# cf - The reference to the current callframe if 'havecf' is true.
# ec - Location to write the Tcl return code into, as an LLVM int*
# reference.
# resultName (optional) -
# A name to give to the result value.
#
# Results:
# None. The command's return value is in the coroutine promise.
method invokeNRE {arguments havecf cf ec {resultName ""}} {
my ExtractVector $arguments
if {!$havecf} {
set cf {}
}
my call ${tcl.invoke.command.nre} [list $len $ary $cf $ec] $resultName
}
# Builder:invokeExpanded --
#
# Generate code to call a Tcl command while doing argument expansion.
# Quadcode implementation ('invokeExpanded').
#
# Parameters:
# arguments -
# The arguments as an LLVM vector value reference. Note that
# this includes the function name as the first argument.
# flags - LLVM bit array indicating which arguments to expand.
# ec - Location to write the Tcl return code into, as an LLVM int*
# reference.
# resultName (optional) -
# A name to give to the result value.
#
# Results:
# An LLVM value reference.
# None. The command's return value is in the coroutine promise.
method invokeExpanded {arguments flags ec {resultName ""}} {
my ExtractVector $arguments
my call ${tcl.invoke.expanded} [list $len $ary $flags $ec] $resultName
}
# Builder:invokeExpandedNRE --
#
# Generate code to call a command with non-recursive eval while doing
# argument expansion. Quadcode implementation ('NRE.invokeExpanded').
#
# Parameters:
# arguments -
# The arguments as an LLVM vector value reference. Note that
# this includes the function name as the first argument.
# flags - LLVM bit array indicating which arguments to expand.
# havecf -
# Tcl boolean indicating if we have a valid callframe.
# cf - The reference to the current callframe if 'havecf' is true.
# ec - Location to write the Tcl return code into, as an LLVM int*
# reference.
# resultName (optional) -
# A name to give to the result value.
#
# Results:
# None.
method invokeExpandedNRE {arguments flags havecf cf ec {resultName ""}} {
my ExtractVector $arguments
if {!$havecf} {
set cf {}
}
my call ${tcl.invoke.expanded.nre} [list $len $ary $flags $cf $ec] \
$resultName
}
method restoreFrame {frame} {
my call ${tcl.restoreFrame} [list $frame]
}
# Builder:isBoolean(INT BOOLEAN) --
#
# Test if a value is a boolean. Quadcode implementation ('isBoolean').
#
# Parameters:
# value - The value to test, as an LLVM value reference.
|
︙ | | |
Changes to codegen/compile.tcl.
︙ | | |
24
25
26
27
28
29
30
31
32
33
34
35
36
37
|
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
|
+
|
# none
oo::class create TclCompiler {
superclass llvmEntity
variable bytecode cmd func quads paramTypes returnType vtypes variables
variable m b pc errorCode currentline currentprocrelline currentscript
variable bytecodeVars namespace objv bitv
variable nreReturnType coro_info
constructor {} {
next
namespace import \
::quadcode::nameOfType \
::quadcode::typeOfLiteral \
::quadcode::typeOfOperand \
|
︙ | | |
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
|
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
|
-
+
+
+
-
+
+
+
+
+
-
+
+
+
+
+
+
+
+
+
|
if {$channel eq ""} {
return [format "%s------>\n%s" $cmd [join $descriptions \n]]
} else {
puts $channel [format "%s------>\n%s" $cmd [join $descriptions \n]]
}
}
# TclCompiler:generateDeclaration --
# TclCompiler:GenerateDeclaration --
#
# Generate the declaration for the function that we are transforming the
# Tcl code into.
#
# Parameters:
# module -
# The module reference (i.e., instance of Module class) to
# generate the function within.
# qs -
# The quadcode sequence
#
# Results:
# The function reference (i.e., instance of Function class) that we have
# generated. Note that this will be an unimplemented function at this
# stage.
method generateDeclaration {module} {
method GenerateDeclaration {module qs} {
set m $module
##############################################################
#
# Compute the argument types
#
set argl {}
set argn {}
foreach typecode $paramTypes {
set type [nameOfType $typecode]
lappend argn $type
lappend argl [Type $type]
}
##############################################################
#
# Compute the return type
#
set rtype char*
foreach insn $qs {
switch -exact -- [lindex $insn 0 0] {
"entry" {
set rtype [nameOfType $returnType]
set rtype [nameOfType $returnType]
break
}
"NRE.entry" {
set nreReturnType [nameOfType $returnType]
break
}
}
}
set returntype [Type $rtype]
##############################################################
#
# Construct the function signature type and the function object.
#
|
︙ | | |
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
|
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
|
+
-
+
+
-
+
-
+
+
+
+
|
}
$func setAsCurrentDebuggingScope
lassign [my GenerateBasicBlocks $quads] blockDict ipathDict pred
array set block $blockDict
array set ipath $ipathDict
# NB: block(-2) contains the alloca's for the function.
# NB: block(-1) is the function entry block. It's supposed to be
# block(-1) is the function entry block. It's supposed to be
# almost entirely optimized out.
$block(-1) build-in $b
$block(-2) build-in $b
$b @location 0
set errorCode [$b alloc int "tcl.errorCode"]
set curr_block $block(-1)
set 0 [$b int 0]
$block(-1) build-in $b
$b @location 0
set curr_block $block(-1)
##############################################################
#
# Create debug info for variables in LLVM
dict for {name typecode} $vtypes {
lassign $name kind formalname origin
set type [nameOfType $typecode]
|
︙ | | |
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
|
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
|
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-
+
+
+
+
+
+
-
-
+
+
+
+
|
} else {
# Not a parameter; set up the debugging metadata as a
# local variable.
$func localvar $formalname $type
}
}
}
foreach insn $quads {
switch -exact -- [lindex $insn 0 0] {
"NRE.entry" {
set coro_info \
[my IssueNREEntrySequence $curr_block $block(0)]
set curr_block $block(0)
break
}
"entry" {
break
}
}
}
##############################################################
#
# Convert Tcl parse output, one instruction at a time.
#
set pc -1
set ERROR_TEMPLATE "\n (compiling \"%s\" @ pc %d: %s)"
set phiAnnotations {}
set phiPending {}
set theframe {}
set thevarmap {}
set syntheticargs {}
set currentline 0
set currentprocrelline 0
set currentscript {}
foreach l $quads {
incr pc
if {[info exists block($pc)]} {
$block($pc) build-in $b
set curr_block $block($pc)
set consumed {}
}
unset -nocomplain tgt
##########################################################
#
# Issue the code for a single quadcode instruction.
#
try {
$b @location $currentline
switch -exact -- [lindex $l 0 0] {
"entry" {
lassign [my IssueEntry $l] \
lassign [my IssueEntry $l $pc $block(-2)] \
theframe thevarmap syntheticargs
}
"NRE.entry" {
lassign [my IssueEntry $l $pc $block(-2)] \
theframe thevarmap syntheticargs
}
"allocObjvForCallees" {
set objc [lindex $l 2 1]
if {$objc > 0} {
$b @location $currentline
set objv [$b allocObjv $objc "objv.for.callees"]
set bitv [$b allocBitv $objc "flags.for.invokeExpanded"]
set objv [$b allocObjv $block(-2) \
$objc "objv.for.callees"]
set bitv [$b allocBitv $block(-2) \
$objc "flags.for.invokeExpanded"]
}
}
"confluence" - "unset" {
# Do nothing; required for SSA computations only
}
"@debug-file" {
}
|
︙ | | |
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
|
637
638
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
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
|
+
-
+
-
+
-
+
-
+
-
+
|
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 vectorValues [lmap s $srcs {my LoadOrLiteral $s}]
set vector [$b buildVector $objv $vectortypes \
set vector [$b buildVector $objv $vectortypes $srcs \
[lmap s $srcs {my LoadOrLiteral $s}]]
$vectorValues]
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
$b clearVector $objv $vectortypes $srcs
}
if {"FAIL" in [my ValueTypes $tgt]} {
my SetErrorLine $errorCode [$b maybe $res]
}
}
"dictSet" - "listSet" {
set srcs [lassign $l opcode tgt srcObj srcValue]
set name [my LocalVarName $tgt]
if {[llength $srcs] == 1} {
# Simple case
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 \
set vector [$b buildVector $objv $vectortypes $srcs \
[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
$b clearVector $objv $vectortypes $srcs
}
if {"FAIL" in [my ValueTypes $tgt]} {
my SetErrorLine $errorCode [$b maybe $res]
}
}
"copy" - "expand" {
lassign $l opcode tgt src
|
︙ | | |
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
|
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
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
|
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
|
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])
}
"NRE.suspend" {
set tgt [lindex $l 1 1]
my CoroSuspend $coro_info $block($tgt)
}
"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)} {
$b addReference($type) $val
}
}
if {$theframe ne "" && ![IsNull $theframe]} {
$b frame.release $theframe $syntheticargs
}
$b ret $val
}
"NRE.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)} {
$b addReference($type) $val
}
}
if {$theframe ne "" && ![IsNull $theframe]} {
$b frame.release $theframe $syntheticargs
}
my CoroReturn $coro_info $val
}
"phi" {
set values {}
set sources {}
foreach {var origin} [lassign $l opcode tgt] {
set spc [lindex $origin end]
while {![info exists block($spc)]} {incr spc -1}
set s $block($spc)
|
︙ | | |
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
|
879
880
881
882
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
|
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
|
foreach aa $arguments {
set arguments [lassign $arguments a]
if {$a ni $arguments && consumed($a, $pc + 1)} {
lappend consumed $a
}
}
}
"NRE.invoke" {
my IssueNREInvoke $theframe $l
}
"invokeExpanded" {
set arguments [my IssueInvokeExpanded $theframe $l]
foreach aa $arguments {
set arguments [lassign $arguments a]
if {$a ni $arguments && consumed($a, $pc + 1)} {
lappend consumed $a
}
}
}
"NRE.invokeExpanded" {
my IssueNREInvokeExpanded $theframe $l
}
"NRE.returnFromInvoke" {
set arguments [my IssueNREReturnFromInvoke $theframe $l]
foreach aa $arguments {
set arguments [lassign $arguments a]
if {$a ni $arguments && consumed($a, $pc + 1)} {
lappend consumed $a
}
}
}
"NRE.returnFromInvokeExpanded" {
set arguments \
[my IssueNREReturnFromInvokeExpanded $theframe $l]
foreach aa $arguments {
set arguments [lassign $arguments a]
if {$a ni $arguments && consumed($a, $pc + 1)} {
lappend consumed $a
}
}
}
"frameArgs" {
|
︙ | | |
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
|
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
|
+
-
+
-
+
-
+
|
}
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 vectorValues [lmap s $srcs {my LoadOrLiteral $s}]
set vector [$b buildVector $objv $vectortypes \
set vector [$b buildVector $objv $vectortypes $srcs \
[lmap s $srcs {my LoadOrLiteral $s}]]
$vectorValues]
set name [my LocalVarName $tgt]
set result [$b concat() $vector $name]
my StoreResult $tgt $result
$b clearVector $vector
$b clearVector $objv $vectortypes $srcs
}
"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 \
|
︙ | | |
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
|
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
|
-
+
-
-
+
+
-
+
+
+
+
-
+
+
|
# dictionary says which block contains the next instruction (necessary
# for forking jumps); i.e., the Instruction Path. The third says which
# blocks are the predecessors of the current block.
method GenerateBasicBlocks {quads} {
# Instructions that will always jump.
set JUMPS {
jump
"jump" "NRE.suspend"
}
# Instructions that can go to either the next instruction OR the named
# instruction.
set FORKJUMPS {
jumpFalse jumpTrue
jumpMaybe jumpMaybeNot
"jumpFalse" "jumpTrue"
"jumpMaybe" "jumpMaybeNot"
}
# Instructions that terminate execution of the function.
set EXITS {return}
set EXITS {
"return" "NRE.return"
}
##############################################################
#
# Create basic blocks
#
set block(-2) [$func block]; # Block(-2) is reserved for alloca's
set block(-1) [$func block]
set block(-1) [$func block]; # Block(-1) is entry code that precedes
; # any user code in the function
set next_is_ipath 1
set pc -1
foreach q $quads {
incr pc
set opcode [lindex $q 0 0]
if {$next_is_ipath >= 0} {
if {![info exists block($pc)]} {
|
︙ | | |
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
|
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
|
-
+
|
##############################################################
#
# Compute the predecessors of each basic block
#
set pc -1
set pred {}
set pred {-1 -2}
set cb $block(-1)
foreach q $quads {
incr pc
if {![info exist cb]} {
set cb $block($pc)
} elseif {[info exist block($pc)]} {
dict lappend pred $block($pc) $cb
|
︙ | | |
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
1185
1186
1187
1188
1189
1190
1191
1192
1193
1194
1195
1196
1197
|
1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220
1221
1222
1223
1224
1225
1226
1227
1228
1229
1230
1231
1232
1233
1234
1235
1236
1237
1238
1239
1240
1241
1242
1243
1244
1245
1246
1247
1248
1249
1250
1251
1252
1253
1254
1255
1256
1257
1258
1259
1260
1261
1262
1263
1264
1265
1266
1267
1268
1269
1270
1271
1272
1273
1274
1275
1276
1277
1278
1279
1280
1281
1282
1283
1284
1285
1286
1287
1288
1289
1290
1291
1292
1293
1294
1295
1296
1297
1298
1299
1300
1301
|
+
+
+
-
+
+
-
+
-
-
-
-
-
-
-
+
+
+
+
+
+
-
+
+
-
+
+
+
-
-
+
+
+
|
# TclCompiler:IssueEntry --
#
# Generate the code for creating a callframe at the start of a function.
# Must only be called from the 'compile' method.
#
# Parameters:
# quad - The 'entry' quadcode, including its parameters.
# pc - The program counter at which the entry appears.
# entryBlock - The Block of the entry to the function, used to make
# sure that any allocations happen early
#
# Results:
# A triple of the callframe, the local variable mapping, and a list
# saying which elements in the callframe are synthetic (i.e., have no
# existing string representation) and need to be released on function
# exit.
method IssueEntry {quad} {
method IssueEntry {quad pc entryBlock} {
lassign $quad opcode tgt vars
# When no frame is wanted
if {$tgt eq {}} {
return [list [$b null CALLFRAME] {} {}]
}
# Store the fact that we must generate complex metadata for this
# function/command, and the variable where this metadata will be
# stored.
if {![dict exists $bytecode procmeta]} {
dict set bytecode procmeta \
[$m variable [list procmeta $cmd] Proc* [$b null Proc*]]
dict set bytecode localcache \
[$m variable [list localcache $cmd] LocalCache* \
[$b null LocalCache*]]
}
# Build the argument list. First, we get the Tcl descriptors of the
# arguments, their types, etc.
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]
}
set argtypes {STRING}
for {incr pc} {[lindex $quads $pc 0] eq "param"} {incr pc} {
set vname [lindex $quads $pc 1]
lappend arguments $vname
lappend argtypes [my ValueTypes $vname]
}
}
set varmeta [dict get $bytecode variables]
# 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}]
foreach v [lindex $vars 1] {
if {$v ni $stdnames} {
lappend varmeta [list scalar $v]
}
}
dict set bytecode variables $varmeta
# Now we allocate the storage for the argument list
set argc [Const [llength $arguments]]
set argv [$b allocInBlock $entryBlock \
set argv [$b alloc [Type array{Tcl_Obj*,[llength $arguments]}] argv]
[Type array{Tcl_Obj*,[llength $arguments]}] argv]
# Store the arguments in the argument list
set cell [$b gep $argv 0 0]
$b store [Const $cmd STRING] $cell
set idx -1
set drop 0
foreach v $arguments t $argtypes {
if {[incr idx]} {
set val [$b stringify($t) [$func param [expr {$idx-1}]]]
$b store $val [$b gep $argv 0 $idx]
lappend drop [expr {!refType($t)}]
}
}
# Create the stack frame
set procmeta [dict get $bytecode procmeta]
set localcache [dict get $bytecode localcache]
set callframe [$b allocInBlock $entryBlock CallFrame "callframe"]
lassign [$b frame.create $varmeta $argc $argv \
[$b load $procmeta "proc.metadata"] \
[$b load $localcache "proc.localcache"]] \
[$b load $procmeta "proc.metadata"] \
[$b load $localcache "proc.localcache"] \
$callframe $entryBlock] \
theframe thevarmap
my StoreResult $tgt $theframe
return [list $theframe $thevarmap $drop]
}
# TclCompiler:IssueInvoke --
#
|
︙ | | |
1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220
1221
1222
1223
1224
1225
1226
1227
1228
1229
1230
1231
1232
1233
1234
1235
1236
1237
1238
1239
1240
1241
1242
1243
1244
1245
1246
1247
1248
1249
1250
1251
1252
1253
1254
1255
1256
1257
1258
1259
1260
1261
1262
1263
1264
1265
1266
1267
1268
1269
1270
1271
1272
1273
1274
1275
1276
1277
1278
1279
1280
1281
1282
1283
1284
1285
1286
1287
1288
1289
1290
1291
1292
1293
1294
1295
1296
1297
1298
1299
1300
1301
1302
1303
1304
1305
1306
1307
1308
1309
1310
1311
|
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
1351
1352
1353
1354
1355
1356
1357
1358
1359
1360
1361
1362
1363
1364
1365
1366
1367
1368
1369
1370
1371
1372
1373
1374
1375
1376
1377
1378
1379
1380
1381
1382
1383
1384
1385
1386
1387
1388
1389
1390
1391
1392
1393
1394
1395
1396
1397
1398
1399
1400
1401
1402
1403
1404
1405
1406
1407
|
-
-
-
+
-
-
-
-
+
-
-
-
-
-
-
-
+
+
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
+
+
-
-
-
-
-
-
-
-
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-
-
+
+
-
-
-
-
-
-
-
-
-
-
-
-
+
-
-
-
-
-
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-
-
+
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
|
# Results:
# The set of arguments that might have been consumed in the operation
# (for cleanup by the caller of this method).
method IssueInvoke {callframe operation} {
set arguments [lassign $operation opcode tgt thecallframe origname]
set vname [my LocalVarName $tgt]
set BASETYPES {ZEROONE INT DOUBLE NUMERIC STRING}
set resolved {}
set called [my ResolveInvoke \
# Is this a literal name for a function we already know the signature
# of? If so, we can use a direct call. To work this out, we need to
# resolve the command within the namespace context of the procedure.
[dict get $vtypes $tgt] $origname $arguments]
if {literal($origname)} {
# Resolve the name.
set name [my FuncName [lindex $origname 1]]
set fullname [my GenerateFunctionName $name arguments $arguments]
if {[$m function.defined $fullname]} {
set called [[$m function.get $fullname] ref]
set argvals [lmap arg $arguments {my LoadOrLiteral $arg}]
if {$called ne {}} {
set argvals [lmap arg $arguments {my LoadOrLiteral $arg}]
my IssueInvokeFunction $tgt $called $argvals $vname
return {}
}
if {[dict exist $vtypes $tgt]} {
set type [nameOfType [dict get $vtypes $tgt]]
if {"FAIL" ni $type || "STRING" ni $type} {
my Warn "didn't find implementation of '$fullname'"
}
}
# Don't need to pre-resolve command names if there's a callframe
if {!callframe($thecallframe)} {
set resolved [my LoadOrLiteral [list literal $name]]
}
}
set arguments [list $origname {*}$arguments]
set argvals [lmap s $arguments {my LoadOrLiteral $s}]
# Dynamic dispatch via direct call is OK, *provided* someone has
# fetched the function reference for us.
if {[TypeOf [lindex $argvals 0]] ne [Type STRING]} {
set argvals [lassign $argvals called]
my IssueInvokeFunction $tgt $called $argvals $vname
return {}
}
} else {
set arguments [linsert $arguments[set arguments ""] 0 $origname]
# Must dispatch via the Tcl command API. This is the slowest option
# with the least type inference possible (everything goes as a
# STRING) but it is a reasonable fallback if nothing else works.
my IssueInvokeCommand $tgt $resolved $arguments $argvals $vname
return $arguments
}
method IssueInvokeFunction {tgt func arguments vname} {
upvar 1 callframe callframe thecallframe thecallframe
set argvals [lmap arg $arguments {my LoadOrLiteral $arg}]
my IssueInvokeCommand $tgt $arguments $argvals $vname
return $arguments
}
}
# TclCompiler:IssueNREInvoke --
#
# Generate the code for invoking another Tcl command by NRE. Must only be
# called from the 'compile' method.
#
# Parameters:
# callframe -
# The callframe.
set BASETYPES {ZEROONE INT DOUBLE NUMERIC STRING}
# operation -
# The quadcode descriptor for the instruction.
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]
method IssueNREInvoke {callframe operation} {
set arguments [lassign $operation opcode tgt thecallframe origname]
set rettype [lindex $opcode 1]
set vname [my LocalVarName $tgt]
set called [my ResolveInvoke $rettype $origname $arguments]
if {$called ne {}} {
set argvals [lmap arg $arguments {my LoadOrLiteral $arg}]
set useCallframe [expr {callframe($thecallframe)}]
set handle [my IssueNREInvokeFunction \
$useCallframe $callframe \
$rettype $tgt $called $argvals $vname]
} else {
set arguments [linsert $arguments[set arguments ""] 0 $origname]
set argvals [lmap arg $arguments {my LoadOrLiteral $arg}]
my IssueNREInvokeCommand $tgt $called $arguments $argvals $vname
}
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 vector [$b buildVector $objv $types $arguments $argvals]
set result [$b invoke $vector \
[expr {callframe($thecallframe)}] $callframe \
$errorCode $vname]
$b clearVector $vector
$b clearVector $objv $types $arguments
# Result type is now FAIL STRING, always.
my SetErrorLine $errorCode [$b maybe $result]
if {callframe($thecallframe)} {
set result [$b frame.pack $callframe $result]
}
my StoreResult $tgt $result
}
method IssueNREInvokeCommand {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 $arguments $argvals]
$b invokeNRE $vector [expr {callframe($thecallframe)}] \
$callframe $errorCode $vname
# For an invoked command, we didn't launch another LLVM coroutine,
# and the Tcl status and command return value will appear
# in the current coroutine's promise.
set result [dict get $coro_info coro_handle]
if {callframe($thecallframe)} {
set result [$b frame.pack $callframe $result]
}
my StoreResult $tgt $result
}
# TclCompiler:IssueInvokeExpanded --
|
︙ | | |
1327
1328
1329
1330
1331
1332
1333
1334
1335
1336
1337
1338
1339
1340
1341
1342
1343
1344
1345
1346
1347
1348
1349
1350
1351
|
1423
1424
1425
1426
1427
1428
1429
1430
1431
1432
1433
1434
1435
1436
1437
1438
1439
1440
1441
1442
1443
1444
1445
1446
1447
1448
1449
1450
1451
1452
1453
1454
1455
1456
1457
1458
1459
1460
1461
1462
1463
1464
1465
1466
1467
1468
1469
1470
1471
1472
1473
1474
1475
1476
1477
1478
1479
1480
1481
1482
1483
1484
1485
1486
1487
1488
1489
1490
1491
1492
1493
1494
1495
1496
1497
1498
1499
1500
1501
1502
1503
1504
1505
1506
1507
1508
1509
1510
1511
1512
1513
1514
1515
1516
1517
1518
1519
1520
1521
1522
1523
1524
1525
1526
1527
1528
1529
1530
1531
1532
1533
1534
1535
1536
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
1562
1563
1564
1565
1566
1567
1568
1569
1570
1571
1572
1573
1574
1575
1576
1577
1578
1579
1580
1581
1582
1583
1584
1585
1586
1587
1588
1589
1590
1591
1592
1593
1594
1595
1596
1597
1598
1599
1600
1601
1602
1603
1604
1605
1606
1607
1608
1609
1610
1611
1612
1613
1614
1615
1616
1617
1618
1619
1620
1621
1622
1623
1624
1625
1626
1627
1628
1629
1630
1631
1632
1633
1634
1635
1636
1637
1638
1639
1640
1641
1642
1643
1644
1645
1646
1647
1648
1649
1650
1651
1652
1653
1654
1655
1656
1657
1658
1659
1660
1661
1662
1663
1664
1665
1666
1667
1668
1669
1670
1671
1672
1673
1674
1675
1676
1677
1678
|
-
+
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
|
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 vector [$b buildVector $objv $types $arguments $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]
}
my StoreResult $tgt $result
$b clearVector $vector
$b clearVector $objv $types $arguments
return $arguments
}
# TclCompiler:IssueNREInvokeExpanded --
#
# Issues the codeburst needed to handle invocation with argument
# expansion in the NRE environment.
#
# Parameters:
# callframe - LLVM reference to the call frame
# operation - The quadcode operation being compiled
#
# Results:
# None.
method IssueNREInvokeExpanded {callframe operation} {
set arguments [lassign $operation opcode tgt thecallframe]
set rettype [lindex $opcode 1]
set vname [my LocalVarName $tgt]
set expandPositions [lmap s $arguments {
expr {"EXPANDED" in [my OperandType $s]}
}]
set argvals [lmap arg $arguments {my LoadOrLiteral $arg}]
set types [lmap s $arguments {my ValueTypes $s}]
set vector [$b buildVector $objv $types $arguments $argvals]
set flags [$b buildBitArray $bitv $expandPositions]
$b invokeExpandedNRE $vector $flags [expr {callframe($thecallframe)}] \
$callframe $errorCode $vname]
# For an invoked command, we didn't launch another LLVM coroutine, and
# the Tcl status and command return value will appear in the current
# coroutine's promise.
set result [dict get $coro_info coro_handle]
if {callframe($thecallframe)} {
set result [$b frame.pack $callframe $result]
}
my StoreResult $tgt $result
}
# TclCompiler:IssueNREReturnFromInvoke --
#
# Generates the code to tidy up after an invoked NRE command returns.
#
# Parameters:
# callframe - The current callframe
# operation - The quadcode operation that represents the return point
#
# Results:
# Returns the set of arguments that might have been consumed in the
# call (for cleanup by the caller of this method).
method IssueNREReturnFromInvoke {callframe operation} {
set arguments [lassign $operation opcode tgt corohandle origname]
set rettype [dict get $vtypes $tgt]
set vname [my LocalVarName $tgt]
set called [my ResolveInvoke $rettype $origname $arguments]
# Built-in types that are handled here.
set BASETYPES {ZEROONE INT DOUBLE NUMERIC STRING}
set ts [lmap t $BASETYPES {Type $t?}]
set tgttype [my ValueTypes $tgt]
if {$called ne {}} {
set destroy 1
} else {
set destroy 0
}
# Emit the sequence that destroys the LLVM coroutine and returns the
# result as 'retval'
lassign [my returnedIntoCoro $rettype $tgttype $corohandle $destroy] \
callframe retcode retval
# Clean up the arguments if needed
if {$called eq {}} {
set arguments [linsert $arguments[set arguments ""] 0 $origname]
set types [lmap s $arguments {my ValueTypes $s}]
$b clearVector $objv $types $arguments
}
# Handle the return
if {$tgttype eq "FAIL"} {
# This procedure only ever fails.
$b store $retval $errorCode
my SetErrorLine $errorCode
} else {
set restype [TypeOf $retval]; # LLVM type ref of the return val
if {$restype in $ts} {
$b store [$b extract $retval 0] $errorCode
} elseif {[Type $restype?] eq [Type $tgttype]} {
set retval [$b ok $retval]
}
if {"FAIL" in $tgttype} {
my SetErrorLine $errorCode [$b maybe $retval]
}
}
# Pack a callframe reference with the return if needed
if {"CALLFRAME" in $tgttype} {
set retval [$b frame.pack $callframe $retval]
}
my StoreResult $tgt $retval
if {$called eq {}} {
return $arguments
} else {
return {}
}
}
# TclCompiler:ResolveInvoke --
#
# Determines whether an invoked command is known as a compiled
# function, and resolves it if it is.
#
# Parameters:
# type - Type of the result of the invocation
# origname - Quadcode value holding the name of the function
# being invoked
# arguments - Arguments being passed to the function being invoked
#
# Results:
# Returns either an LLVM value reference to the function to call,
# or {} if there is no known function to call and the invocation
# must go through Tcl's evaluator.
method ResolveInvoke {type origname arguments} {
if {literal($origname)} {
set name [my FuncName [lindex $origname 1]]
set fullname [my GenerateFunctionName $name arguments $arguments]
if {[$m function.defined $fullname]} {
return [[$m function.get $fullname] ref]
}
set type [nameOfType $type]
if {"FAIL" ni $type || "STRING" ni $type} {
my Warn "$fullname is not implemented, but result is not\
FAIL STRING."
}
}
return {}
}
# TclCompiler:IssueInvokeFunction --
#
# Issues the invocation sequence of a builtin function or compiled proc
#
# Parameters:
# tgt - Descriptor of the value where the result is to be stored
# func - LLVM value representing the function to invoke
# arguments - List of descriptors of the arguments to pass
# vname - Name of the result value
#
# Results:
# None
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
}
# TclCompiler:IssueNREInvokeFunction --
#
# Issues the invocation sequence of a builtin function or compiled proc
#
# Parameters:
# rettype - Return type of the function to be invoked. This is
# necessary because the type of $tgt will always be
# 'LLVM coroutine handle'
# tgt - Descriptor of the value where the result is to be stored
# func - LLVM value representing the function to invoke
# arguments - List of descriptors of the arguments to pass
# vname - Name of the result value
#
# Results:
# None
method IssueNREInvokeFunction {useCallframe callframe \
rettype tgt func arguments vname} {
set result [$b call $func $arguments $vname]
$b launchCoroRunner $result
if {$useCallframe} {
set result [$b frame.pack $callframe $result]
}
my StoreResult $tgt $result
}
method IssueInvokeCommand {tgt arguments argvals vname} {
upvar 1 callframe callframe thecallframe thecallframe
set types [lmap s $arguments {my ValueTypes $s}]
# FIXME: The front end needs to pass through command info
# prior to resolution as well as after, so as to produce
# proper error messages. This will get complicated in the
# presence of ensembles; we ignore the problem for now.
set vector [$b buildVector $objv $types $arguments $argvals]
set result [$b invoke $vector \
[expr {callframe($thecallframe)}] $callframe \
$errorCode $vname]
$b clearVector $objv $types $arguments
# Result type is now FAIL STRING, always.
my SetErrorLine $errorCode [$b maybe $result]
if {callframe($thecallframe)} {
set result [$b frame.pack $callframe $result]
}
my StoreResult $tgt $result
}
# TclCompiler:IssueWiden --
#
# Generate the code for widening the type of a value. Must only be
# called from the 'compile' method.
#
# Parameters:
|
︙ | | |
1549
1550
1551
1552
1553
1554
1555
1556
1557
1558
1559
1560
1561
1562
1563
1564
1565
1566
1567
1568
1569
|
1876
1877
1878
1879
1880
1881
1882
1883
1884
1885
1886
1887
1888
1889
1890
1891
1892
1893
1894
1895
1896
|
+
-
+
-
-
+
|
} 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 argvals [lmap s $srcs {my LoadOrLiteral $s}]
set vector [$b buildVector $objv $types \
set vector [$b buildVector $objv $types $srcs $argvals]
[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
$b clearVector $objv $types $srcs
return
}
# TclCompiler:IssueExtract --
#
# Generate the code for exactracting the value of a variable which
# contains a "possibly-existing" value. Must only be called from the
|
︙ | | |
1991
1992
1993
1994
1995
1996
1997
1998
1999
2000
2001
2002
2003
2004
2005
2006
|
2318
2319
2320
2321
2322
2323
2324
2325
2326
2327
2328
2329
2330
2331
2332
2333
2334
2335
2336
|
+
+
-
-
+
+
+
|
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' of type '%s' \
into a variable, '%s', of type '%s'"\
'[PrintValueToString $value]'\
into a variable, '$desc', of type '$destType'"
[PrintValueToString $value] \
[PrintTypeToString [TypeOf $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
|
︙ | | |
2096
2097
2098
2099
2100
2101
2102
2103
2104
2105
2106
2107
2108
2109
2110
2111
2112
2113
2114
2115
2116
2117
2118
2119
2120
2121
2122
2123
2124
2125
2126
2127
2128
|
2426
2427
2428
2429
2430
2431
2432
2433
2434
2435
2436
2437
2438
2439
2440
2441
2442
2443
2444
2445
2446
2447
2448
2449
2450
2451
2452
2453
2454
2455
2456
2457
2458
2459
|
-
-
+
+
-
+
+
|
#
# Results:
# The PC at which the 'free' occurs, or 0 if the value isn't consumed
# (there is never a free as the first instruction in a function, so this
# may be used as a boolean).
method IsConsumed {var search} {
while 1 {
switch [lindex $quads $search 0] {
while {$search < [llength $quads]} {
switch [lindex $quads $search 0 0] {
"free" {
if {[lindex $quads $search 2] eq $var} {
return $search
}
}
"jump" - "jumpFalse" - "jumpTrue" - "return" -
"jumpMaybe" - "jumpMaybeNot" {
"jumpMaybe" - "jumpMaybeNot" - "NRE.return" - "NRE.suspend" {
return 0
}
default {
if {$var in [lindex $quads $search]} {
return 0
}
}
}
incr search
}
error "IsConsumed ran away!"
}
# TclCompiler:ConvertIndices --
#
# Convert the most common cases of literal end-based indexing into forms
# that can actually be processed by the low-level code issuer.
#
|
︙ | | |
2229
2230
2231
2232
2233
2234
2235
2236
2237
2238
2239
2240
2241
2242
|
2560
2561
2562
2563
2564
2565
2566
2567
2568
2569
2570
2571
2572
2573
2574
2575
2576
2577
2578
2579
2580
2581
|
+
+
+
+
+
+
+
+
|
my ByteCode $command [::tcl::unsupported::getbytecode proc $command]
set info [$specializer makeInstance $command $argumentTypes]
lassign $info rt ats tmap quadcode
my InitTypeInfo $ats $rt $tmap
set ats [lmap t $ats {nameOfType $t}]
set readableName ${cmd}([string map {" " .} [join $ats ,]])
}
# TclInterprocedureCompiler:needsNRE --
#
# Return 1 if the function we are compiling needs NRE, 0 otherwise.
#
method needsNRE {} {
expr {[lindex $quadcode 0 0] eq "NRE.entry"}
}
# TclInterproceduralCompiler:commandName (property) --
#
# Get the human-readable name of the function we are compiling/have
# compiled. Note that this is not necessarily the same as the name of
# the function in the code *or* the name of the Tcl command that will be
# replaced by this function.
|
︙ | | |
2263
2264
2265
2266
2267
2268
2269
2270
2271
2272
2273
2274
2275
2276
2277
2278
2279
2280
2281
2282
2283
2284
2285
2286
2287
2288
2289
2290
2291
2292
2293
2294
2295
2296
2297
|
2602
2603
2604
2605
2606
2607
2608
2609
2610
2611
2612
2613
2614
2615
2616
2617
2618
2619
2620
2621
2622
2623
2624
2625
2626
2627
2628
2629
2630
2631
2632
2633
2634
2635
2636
2637
2638
2639
2640
2641
2642
2643
2644
2645
2646
2647
2648
2649
2650
2651
2652
2653
2654
2655
2656
2657
2658
2659
2660
2661
2662
2663
2664
2665
2666
2667
|
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-
+
|
my Compile $quadcode
} on error {msg opts} {
dict append opts -errorinfo \
"\n (compiling code for \"$cmd\")"
return -options $opts $msg
}
}
# TclInterproceduralCompiler:generateDeclaration --
#
# Generate the declaration of the function that we transformed the
# procedure into.
#
# Parameters:
# module - Module that we're compiling into.
method generateDeclaration {module} {
try {
my GenerateDeclaration $module $quadcode
} on error {msg opts} {
dict append opts -errorinfo \
"\n (compiling code for \"$cmd\")"
return -options $opts $msg
}
}
# TclInterproceduralCompiler:generateThunk --
#
# Generate the binding into Tcl of the function that we transformed the
# procedure into.
#
# Parameters:
# thunkBuilder -
# The API binding class instance.
#
# Results:
# The function reference (i.e., instance of Function class) for the
# binding function. (Not the bound function, which this class made.)
method generateThunk {thunkBuilder} {
my variable returnType
if {[dict exists $bytecode procmeta]} {
$thunkBuilder buildProcedureMetadata $cmd $bytecode \
[dict get $bytecode procmeta]
dict unset bytecode procmeta
}
set isNRE 0
foreach q $quadcode {
switch -exact [lindex $q 0 0] {
"entry" {
break
}
"NRE.entry" {
set isNRE 1
break
}
}
}
$thunkBuilder thunk $cmd $bytecode $func
$thunkBuilder thunk $cmd $bytecode $func $isNRE [nameOfType $returnType]
}
# TclInterproceduralCompiler:printTypedQuads --
#
# Print the sequence of typed quadcodes that the type inference engine
# has transformed the procedure into.
#
|
︙ | | |
Changes to codegen/config.tcl.
Added codegen/coro.tcl.