Many hyperlinks are disabled.
Use anonymous login
to enable hyperlinks.
Changes In Branch fix-call-resolution
Excluding Merge-Ins
This is equivalent to a diff from
55314ea72f
to cd60d83f32
2017-12-25
| | |
17:56 |
|
check-in: a86e497781 user: dkf tags: trunk
|
2017-12-23
| | |
08:38 |
|
Leaf
check-in: cd60d83f32 user: dkf tags: fix-call-resolution
|
2017-12-20
| | |
09:25 |
|
check-in: 4f606de75c user: dkf tags: fix-call-resolution
|
2017-12-19
| | |
23:57 |
|
check-in: 55314ea72f user: dkf tags: trunk
|
23:55 |
|
Closed-Leaf
check-in: 691e663c5f user: dkf tags: dkf-dict-update
|
21:28 |
|
check-in: 8a771984d2 user: dkf tags: trunk
|
| | |
Changes to codegen/build.tcl.
︙ | | |
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
4501
4502
4503
4504
4505
4506
4507
4508
4509
4510
4511
4512
4513
4514
4515
4516
|
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
4501
4502
4503
4504
4505
4506
4507
4508
4509
4510
4511
4512
4513
4514
4515
4516
4517
4518
|
+
-
+
-
+
+
-
+
-
+
|
# Parameters:
# arguments -
# The arguments as an LLVM vector 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.
# ns - The official current namespace, as Namespace*.
# 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 ""}} {
method invoke {arguments havecf cf ns ec {resultName ""}} {
my ExtractVector $arguments
if {!$havecf} {
set cf {}
}
my call ${tcl.invoke.command} [list $len $ary $cf $ec] $resultName
my call ${tcl.invoke.command} [list $len $ary $cf $ns $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.
# ns - The official current namespace, as Namespace*.
# 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 invokeExpanded {arguments flags ec {resultName ""}} {
method invokeExpanded {arguments flags ns ec {resultName ""}} {
my ExtractVector $arguments
my call ${tcl.invoke.expanded} [list $len $ary $flags $ec] $resultName
my call ${tcl.invoke.expanded} [list $len $ary $flags $ns $ec] $resultName
}
# Builder:isBoolean(INT BOOLEAN) --
#
# Test if a value is a boolean. Quadcode implementation ('isBoolean').
#
# Parameters:
|
︙ | | |
Changes to codegen/compile.tcl.
︙ | | |
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
|
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
|
-
+
|
#
try {
$b @location $currentline
switch -exact -- [lindex $l 0 0] {
"entry" {
lassign [my IssueEntry $l] \
theframe thevarmap syntheticargs
theframe thevarmap thens syntheticargs
}
"confluence" - "unset" {
# Do nothing; required for SSA computations only
}
"@debug-line" {
lassign $l opcode - srcfrom
set currentline [lindex $srcfrom 1]
|
︙ | | |
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
|
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
|
-
+
-
+
|
foreach {name value} $phiAnnotations {
my AnnotateAssignment $name $value
}
set phiAnnotations {}
}
}
"invoke" {
set arguments [my IssueInvoke $theframe $l]
set arguments [my IssueInvoke $theframe $l $thens]
foreach aa $arguments {
set arguments [lassign $arguments a]
if {$a ni $arguments && consumed($a, $pc + 1)} {
lappend consumed $a
}
}
}
"invokeExpanded" {
set arguments [my IssueInvokeExpanded $theframe $l]
set arguments [my IssueInvokeExpanded $theframe $l $thens]
foreach aa $arguments {
set arguments [lassign $arguments a]
if {$a ni $arguments && consumed($a, $pc + 1)} {
lappend consumed $a
}
}
}
|
︙ | | |
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
|
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
|
+
+
-
+
|
# exit.
method IssueEntry {quad} {
lassign $quad opcode tgt vars
# When no frame is wanted
if {$tgt eq {}} {
# FIXME: get namespace
set ns {}
return [list [$b null CALLFRAME] {} {}]
return [list [$b null CALLFRAME] {} $ns {}]
}
# 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 \
|
︙ | | |
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
|
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
|
+
-
+
+
-
+
-
-
+
+
+
-
+
+
-
-
-
-
-
+
+
-
-
-
+
|
set procmeta [dict get $bytecode procmeta]
set localcache [dict get $bytecode localcache]
lassign [$b frame.create $varmeta $argc $argv \
[$b load $procmeta "proc.metadata"] \
[$b load $localcache "proc.localcache"]] \
theframe thevarmap
my StoreResult $tgt $theframe
set thens [$b dereference $theframe 0 CallFrame.nsPtr]
return [list $theframe $thevarmap $drop]
return [list $theframe $thevarmap $thens $drop]
}
# TclCompiler:IssueInvoke --
#
# Generate the code for invoking another Tcl command. Must only be
# called from the 'compile' method.
#
# Parameters:
# callframe -
# The callframe.
# operation -
# The quadcode descriptor for the instruction.
# thens - The current namespace, used for command resolution.
#
# 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} {
method IssueInvoke {callframe operation thens} {
set arguments [lassign $operation opcode tgt thecallframe origname]
set vname [my LocalVarName $tgt]
set BASETYPES {ZEROONE INT DOUBLE NUMERIC STRING}
set resolved {}
# 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.
if {literal($origname)} {
# Resolve the name.
set name [my FuncName [lindex $origname 1]]
set fullname [my GenerateFunctionName $name arguments $arguments]
set fullname [my GenerateFunctionName $name arguments \
[lrange $arguments 1 end]]
if {[$m function.defined $fullname]} {
set called [[$m function.get $fullname] ref]
set argvals [lmap arg [lrange $arguments 1 end] {
set argvals [lmap arg $arguments {my LoadOrLiteral $arg}]
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 {}
}
# 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
my IssueInvokeCommand $tgt $arguments $argvals $thens $vname
return $arguments
}
method IssueInvokeFunction {tgt func arguments vname} {
upvar 1 callframe callframe thecallframe thecallframe
set BASETYPES {ZEROONE INT DOUBLE NUMERIC STRING}
|
︙ | | |
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
|
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
|
-
+
-
-
-
-
-
+
+
-
+
-
+
|
if {callframe($thecallframe)} {
set result [$b frame.pack $callframe $result]
}
my StoreResult $tgt $result
}
method IssueInvokeCommand {tgt resolved arguments argvals vname} {
method IssueInvokeCommand {tgt arguments argvals thens 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 $types $argvals]
set result [$b invoke $vector \
[expr {callframe($thecallframe)}] $callframe \
$errorCode $vname]
$thens $errorCode $vname]
$b clearVector $arguments $vector $types
# 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:IssueInvokeExpanded --
#
# Generate the code for invoking another Tcl command with expansion.
# Must only be called from the 'compile' method.
#
# Parameters:
# callframe -
# The callframe.
# operation -
# The quadcode descriptor for the instruction.
# thens - The current namespace, used for command resolution.
#
# Results:
# The set of arguments that might have been consumed in the operation
# (for cleanup by the caller of this method).
method IssueInvokeExpanded {callframe operation} {
method IssueInvokeExpanded {callframe operation thens} {
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 $types $argvals]
set flags [$b buildBitArray $expandPositions]
set result [$b invokeExpanded $vector $flags $errorCode $vname]
set result [$b invokeExpanded $vector $flags $thens $errorCode $vname]
my SetErrorLine $errorCode [$b maybe $result]
my StoreResult $tgt [$b frame.pack $callframe $result]
$b clearVector $arguments $vector $types
return $arguments
}
# TclCompiler:IssueWiden --
|
︙ | | |
Changes to codegen/stdlib.tcl.
︙ | | |
4198
4199
4200
4201
4202
4203
4204
4205
4206
4207
4208
4209
4210
4211
4212
4213
4214
4215
4216
4217
4218
4219
4220
4221
4222
4223
|
4198
4199
4200
4201
4202
4203
4204
4205
4206
4207
4208
4209
4210
4211
4212
4213
4214
4215
4216
4217
4218
4219
4220
4221
4222
4223
4224
4225
|
-
+
+
-
-
+
+
-
-
+
+
+
|
set NULL [my null Interp*]
set code [my setFromAny [$api tclBooleanType] $NULL $objPtr]
my ret [my eq $code $0]
}
##### Function tcl.invoke.command #####
#
# Type signature: objc:int * objv:STRING* * ecvar:int* -> STRING?
# Type signature: objc:int * objv:STRING* * nsptr:Namespace*
# * ecvar:int* -> STRING?
#
# Calls the Tcl interpreter to invoke a Tcl command, and packs the
# result into a STRING FAIL.
set f [$module local "tcl.invoke.command" \
STRING?<-int,STRING*,CALLFRAME,int*]
params objc objv frame ecvar
STRING?<-int,STRING*,CALLFRAME,Namespace*,int*]
params objc objv frame nsptr ecvar
build {
noalias $objv $frame $ecvar
nonnull $objv $ecvar
noalias $objv $frame $nsptr $ecvar
nonnull $objv $nsptr $ecvar
set interp [$api tclInterp]
my storeInStruct $interp Interp.lookupNsPtr $nsptr
my condBr [my nonnull $frame] $frameInvoke $stdInvoke
label stdInvoke "invoke.standard"
set code1 [$api Tcl_EvalObjv $interp $objc $objv $0]
my condBr [my eq $code1 $0] $ok $fail
label frameInvoke "invoke.with.callframe"
set vfp [my gep $interp 0 Interp.varFramePtr]
set vf [my load $vfp]
|
︙ | | |
4233
4234
4235
4236
4237
4238
4239
4240
4241
4242
4243
4244
4245
4246
4247
4248
4249
4250
4251
4252
4253
4254
4255
4256
4257
4258
4259
|
4235
4236
4237
4238
4239
4240
4241
4242
4243
4244
4245
4246
4247
4248
4249
4250
4251
4252
4253
4254
4255
4256
4257
4258
4259
4260
4261
|
-
-
+
+
-
-
+
+
-
-
+
+
|
set code [my phi [list $code1 $code2] [list $stdInvoke $frameInvoke] "code"]
my store $code $ecvar
my ret [my fail STRING $code]
}
##### Function tcl.invoke.expanded #####
#
# Type signature: objc:int * objv:STRING* * flags:bool* * ecvar:int*
# -> STRING?
# Type signature: objc:int * objv:STRING* * flags:bool*
# * nsptr:Namespace* * ecvar:int* -> STRING?
#
# Calls the Tcl interpreter to invoke a Tcl command, first expanding
# the arguments indicate by the flags array (which will have objc
# elements in it), and packs the result into a STRING FAIL.
set f [$module local "tcl.invoke.expanded" \
STRING?<-int,STRING*,bool*,int*]
params objc objv flags ecvar
STRING?<-int,STRING*,bool*,Namespace*,int*]
params objc objv flags nsptr ecvar
build {
noalias $objv $flags $ecvar
nonnull $objv $flags $ecvar
noalias $objv $flags $nsptr $ecvar
nonnull $objv $flags $nsptr $ecvar
set tclobjSize [my cast(int) [my sizeof STRING]]
set interp [$api tclInterp]
set iPtr [my alloc int "i"]
set jPtr [my alloc int "j"]
set lenPtr [my alloc int "len"]
set objcPtr [my alloc int "objcPtr"]
set objvPtr [my alloc STRING* "objvPtr"]
|
︙ | | |
4308
4309
4310
4311
4312
4313
4314
4315
4316
4317
4318
4319
4320
4321
|
4310
4311
4312
4313
4314
4315
4316
4317
4318
4319
4320
4321
4322
4323
4324
|
+
|
my store $obj $target
my store [my add $j $1] $jPtr
my br $expansionNext
label expansionNext "next.expansion"
my store [my add $i $1] $iPtr
my br $expansionTest
label invoke:
my storeInStruct $interp Interp.lookupNsPtr $nsptr
set code [$api Tcl_EvalObjv $interp $len $ary $0]
$api ckfree $ary
my condBr [my eq $code $0] $ok $fail
label ok:
set result [$api Tcl_GetObjResult $interp]
my addReference(STRING) $result
my ret [my ok $result]
|
︙ | | |
Changes to quadcode/builtin_specials.tcl.
︙ | | |
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
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
|
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
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
|
-
-
-
-
-
+
+
+
+
+
+
+
-
-
+
+
+
+
+
-
+
-
+
|
# Results:
# Returns the frame effect.
oo::define quadcode::specializer method frameEffect___lsort {q} {
if {[lindex $q 0] eq "invokeExpanded"} {
# lsort with {*} for the args - punt
my diagnostic error "lsort with argument expansion is not supported yet"
return {reads 0 writes 0 readsNonLocal {} writesNonLocal {}}
}
# Only [lsort - command] has an interesting frame effect
return {
reads 0 writes 0 readsNonLocal {} writesNonLocal {}
error "lsort with argument expansion is not supported yet"
}
}
# Only [lsort -command] has an interesting frame effect
# Only [lsort -command] might use callframe data
lassign [my parse___lsort $q] usesCommand command
if {!$usesCommand} {
return {killable Inf noCallFrame {} pure {}}
}
# TODO: We can't analyze [lsort -command] yet, but we could.
# What it would take is to generate bytecode for the
# command prefix with two dummy arguments, and then
# determine the effect of the bytecode on the callframe.
my diagnostic error "lsort -command is not supported yet"
return {reads 0 writes 0 readsNonLocal {} writesNonLocal {}}
return {
reads 0 writes 0 readsNonLocal {} writesNonLocal {}
error "lsort -command is not supported yet"
}
}
# quadcode::specializer method frameEffect___regexp --
#
# Determines the callframe effect of the [regexp] command
#
# Parameters:
# q - The quadcode instruction that invokes 'regexp'
#
# Results:
# Returns the frame effect.
oo::define quadcode::specializer method frameEffect___regexp {q} {
# 0 - 'invoke'
# 1 - result callframe
# 2 - input callframe
# 3 - ::regexp
# 4 - regexp
# 4+ - remaining args
# 5+ - remaining args
if {[lindex $q 0] eq "invokeExpanded"} {
# can't figure out what vars are written, but we know there are
# no other untoward side effects
return {reads 0 writes 0}
}
# Skip over the command line switches
set ind 4
set ind 5
while {$ind < [llength $q] - 2} {
if {[lindex $q $ind 0] ne "literal"} {
return {writes 0}
}
switch -exact -- [lindex $q $ind 1] {
-about -
-expanded -
|
︙ | | |
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
|
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
|
+
-
+
-
+
|
oo::define quadcode::specializer method frameEffect___regsub {q} {
# 0 - 'invoke'
# 1 - result callframe
# 2 - input callframe
# 3 - ::regsub
# 4 - regsub
# 4+ - remaining args
# 5+ - remaining args
if {[lindex $q 0] eq "invokeExpanded"} {
# can't figure out variable effects but otherwise the command is benign
return {reads 0 writes 0}
}
# Skip over the command line switches
set ind 4
set ind 5
while {$ind < [llength $q]} {
if {[lindex $q $ind 0] ne "literal"} {
if {$ind + 3 == [llength $q]} {
return {killable Inf noCallFrame {} pure {}}
} else {
return [dict create writes $ind]
}
|
︙ | | |
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
|
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
|
-
+
|
#
# Results:
# Returns a two-element list. The first element is a flag for
# whether -command is present; the second is the command provided.
oo::define quadcode::specializer method parse___lsort {q} {
set ind 4
set ind 5
while {$ind + 1 < [llength $q]} {
if {[lindex $q $ind 0] eq "literal"} {
set opt [lindex $q $ind 1]
} else {
error "substitution in lsort flags is not supported."
}
switch -exact -- $opt {
|
︙ | | |
Changes to quadcode/callframe.tcl.
︙ | | |
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
|
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
|
-
+
|
"invoke" - "invokeExpanded" {
# The variables altered by the 'invoke', plus
# all aliases, are potentially changed.
set aliases {}
set atypes [lmap x [lrange $producer 4 end] {
set atypes [lmap x [my invoke-args $producer] {
typeOfOperand $types $x
}]
lassign [my variablesProducedBy $producer $atypes] \
known wlist
if {$known} {
foreach v $wlist {
dict set aliases $v {}
|
︙ | | |
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
|
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
|
-
+
|
}
lset bbcontent $b [incr outpc] $q
continue
}
# Determine argument types of the consuming call, which always
# begins with some output and a callframe input
set atypes [lmap x [lrange $consumer 4 end] {
set atypes [lmap x [my invoke-args $consumer] {
typeOfOperand $types $x
}]
# Find out what variables that the consumer potentially reads.
# Because potentially changed variables may also be unchanged,
# list them also.
|
︙ | | |
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
|
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
|
-
+
|
# A callframe is always in a temporary
if {[lindex $toCF 0] ne "temp"} continue
# Is the result a callframe, and can we eliminate it?
set toCFType [typeOfOperand $types $toCF]
if {$opcode in {"invoke" "invokeExpanded"}} {
set atypes [lmap x [lrange $q 4 end] {
set atypes [lmap x [my invoke-args $q] {
typeOfOperand $types $x
}]
} else {
set atypes {}
}
if {($toCFType & $CALLFRAME)
&& [my canEliminateCallFrame $q $atypes]} {
|
︙ | | |
1361
1362
1363
1364
1365
1366
1367
|
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
|
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
|
# name in the next outer callframe, so can't be done safely.
# If none of the above conditions hold, the callframe reference and
# definition can be removed safely from the quad.
return 1
}
# quadcode::transformer method invoke-args --
#
# Get the real arguments (other than the command name) that will
# be used with the invocation.
#
# Parameters:
# q - Quadcode instruction that produces a callframe.
#
# Results:
# Returns the list of arguments (quadcode values) if they are
# meaningful, otherwise produces an error..
oo::define quadcode::transformer method invoke-args {q} {
switch [lindex $q 0 0] {
"invoke" {
return [lrange $q 5 end]
}
"invokeExpanded" {
return [lrange $q 4 end]
}
"" {
# What is going on here?
return
}
default {
return -code error "cannot get invoke arguments from non-invoke\
opcode '$q'"
}
}
}
|
Changes to quadcode/fqcmd.tcl.
︙ | | |
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
|
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
|
-
+
-
+
|
oo::define quadcode::transformer method fqcmd {} {
set b 0
foreach content $bbcontent {
set i 0
foreach q $content {
if {[lindex $q 0 0] in {"invoke" "invokeExpanded"}
&& [lindex $q 3 0] eq "literal"} {
&& [lindex $q 3 0] eq "literal"} {
set cmdname [lindex $q 3 1]
set resolved \
[namespace eval $ns [list namespace which $cmdname]]
if {$resolved ne {}} {
set cmdname $resolved
}
if {![catch {
namespace eval $ns [list namespace origin $cmdname]
} resolved]} {
set cmdname $resolved
set cmdname $resolved
}
lset bbcontent $b $i 3 1 $cmdname
}
incr i
}
incr b
}
}
|
Changes to quadcode/translate.tcl.
︙ | | |
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
|
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
|
-
+
+
-
+
+
|
# the invoked procedure raises an error
set qd [list [list temp [expr {$depth + $acount}]]]
for {set i $rcount} {$i < $acount} {incr i} {
lappend qd [list temp [expr {$depth + $i}]]
}
my generate-function-param-check $pc $qd
# generate the call itself
my quads invoke {temp @callframe} {temp @callframe} {*}$qd
my quads invoke {temp @callframe} {temp @callframe} \
[lindex $qd 0] {*}$qd
my quads retrieveResult $result {temp @callframe}
my quads extractCallFrame {temp @callframe} {temp @callframe}
my generate-jump [my exception-target $pc catch] maybe $result
my quads extractMaybe $result $result
}
invokeStk1 - invokeStk4 {
set acount [lindex $insn 1]
set depth [expr {$depth - $acount}]
set result [list temp $depth]
set qd {}
for {set i 0} {$i < $acount} {incr i} {
lappend qd [list temp [expr {$depth + $i}]]
}
my generate-function-param-check $pc $qd
# generate the call itself
my quads invoke {temp @callframe} {temp @callframe} {*}$qd
my quads invoke {temp @callframe} {temp @callframe} \
[lindex $qd 0] {*}$qd
my quads retrieveResult $result {temp @callframe}
my quads extractCallFrame {temp @callframe} {temp @callframe}
my generate-jump [my exception-target $pc catch] maybe $result
my quads extractMaybe $result $result
}
jump1 - jump4 {
switch -exact -- [lindex $insn 1 0] {
|
︙ | | |
Changes to quadcode/upvar.tcl.
︙ | | |
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
|
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
|
-
+
+
+
+
+
+
+
|
# must do: dict unset result killable;
}
}
}
"invoke" {
set did 1
set argList [lassign $q opcode cfout cfin cmdName]
set argList [lassign $q opcode cfout cfin resolvedcCmdName orignalCmdName]
set typeList [lmap arg $argList {typeOfOperand $types $arg}]
if {[catch {
$specializer frameEffect $q $typeList
} attrs]} {
my diagnostic error $b $pc $attrs
set attrs {readsAny 1 readsNonLocal 1 \
writesAny 1 writesNonLocal 1}
}
foreach dgtype {error warning} {
if {[dict exists $attrs $dgtype]} {
my diagnostic $dgtype $b $pc [dict get $attrs $dgtype]
dict unset attrs $dgtype
}
}
my upvarInvoke result $aliasInfo $attrs $q $typeList
}
}
my debug-upvar {
|
︙ | | |
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
|
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
|
-
-
-
|
# None.
#
# Side effects:
# Records the effect of the 'invoke' on the current callframe.
oo::define quadcode::transformer method upvarInvoke {resultV aliasInfo
effect q typeList} {
upvar 1 $resultV result
set callframe [lindex $q 1]
# Record purity
if {![dict exists $effect pure]} {
dict unset result pure
}
|
︙ | | |
Changes to quadcode/varargs.tcl.
︙ | | |
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
|
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
|
-
+
|
# Updates ud- and du-chains.
oo::define quadcode::transformer method varargsRewriteInvoke {b pc q} {
set newqds {}
# Take apart the quad
set argv [lassign $q opcode cfout cfin calleeLit]
set argv [lassign $q opcode cfout cfin calleeLit origCallee]
# We care only about 'invoke' instructions where the procedure name
# is known a priori, the expected args are known, and the
# target procedure is compiled.
if {[lindex $calleeLit 0] ne "literal"
|| [catch {
set callee [lindex $calleeLit 1]
|
︙ | | |
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
|
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
|
-
+
|
# compilation going.
return
}
# Make a new quad that passes all supplied params that
# don't go in 'args'. Set 'paramsLeft' to the list of
# parameters that weren't filled.
set newq [list invoke $cfout $cfin $calleeLit \
set newq [list invoke $cfout $cfin $calleeLit $origCallee \
{*}[lrange $argv 0 [expr {$nonargs-1}]]]
set paramsleft [lrange $arginfo [llength $argv] [expr {$nonargs-1}]]
# If we need to fill in optional parameters, do that now
foreach param $paramsleft {
if {![info default $callee $param defaultv]} {
my diagnostic error "Too few args provided to $callee"
|
︙ | | |
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
|
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
|
-
+
|
my debug-varargs {
puts "[my full-name]: $b:$pc: $q"
}
# Make the first part of the 'invoke' instruction that will
# replace the 'invokeExpanded'
set newq [list invoke $cfout $cfin $calleeLit]
set newq [list invoke $cfout $cfin $calleeLit $calleeLit]
# We are going to be doing major surgery on the basic block.
# Remove the 'invokeExpanded' and all following instructions
# from the block. Unlink the block from its successors, and
# remove ud- and du-chaining for the removed instructions.
lassign [my varargsUnlinkTail $b $pc] bb tail
|
︙ | | |