Check-in [8c6a038bf1]

Many hyperlinks are disabled.
Use anonymous login to enable hyperlinks.

Overview
Comment:Move more 'alloca' instructions to the entry block, before they can mess up coro.begin. Allow NRE procs to return CALLFRAME COROHANDLE, needed for bookkeeping if they both use NRE and reference the callframe. Put in a test case for the CALLFRAME COROHANDLE condition - that case still crashes
Timelines: family | ancestors | descendants | both | notworking | kbk-nre
Files: files | file ages | folders
SHA3-256:8c6a038bf11ca71368cca1c094b64e600662f5e884397f01edc67794b6ca5100
User & Date: kbk 2018-04-27 20:32:01
Context
2018-04-28
08:25
Added mrtest as a separately buildable package. check-in: 05a6521445 user: dkf tags: kbk-nre
2018-04-27
20:32
Move more 'alloca' instructions to the entry block, before they can mess up coro.begin. Allow NRE procs to return CALLFRAME COROHANDLE, needed for bookkeeping if they both use NRE and reference the callframe. Put in a test case for the CALLFRAME COROHANDLE condition - that case still crashes check-in: 8c6a038bf1 user: kbk tags: notworking, kbk-nre
2018-04-25
00:59
Improve commentary check-in: 7a5af13a50 user: kbk tags: kbk-nre
Changes

Changes to codegen/build.tcl.

561
562
563
564
565
566
567

568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
....
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
....
4477
4478
4479
4480
4481
4482
4483
4484
4485
4486
4487
4488
4489
4490
4491
    #	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.

    #
    # 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} {
	# Construct the call frame itself
	set callframe [my alloc CallFrame "callframe"]
	set length [Const [llength $varlist]]
	set locals [my arrayAlloc 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 {}
................................................................................
    }

    # Builder:allocBitv --
    #
    #	Allocate a bit vector of a given length.
    #
    # Parameters:

    #	len - The length of the vector

    #
    # 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 {}}} {
	set type [Type array{bool,$len}]
	set bits [my alloc $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:

    #	len - The length of the vector

    #
    # 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 {}}} {
	set type [Type array{STRING,$len}]
	set strs [my alloc $type ${name}.space]
	set first [my gep $strs 0]
	SetValueName $first $name
	return $first
    }

    # Builder:appendString --
    #
................................................................................
    # Builder:invoke --
    #
    #	Generate code to call a Tcl command.  Quadcode implementation
    #	('invoke').
    #
    # 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.
    #	ec -	Location to write the Tcl return code into, as an LLVM int*
    #		reference.
    #	resultName (optional) -







>






|

<







 







>

>







|

|










>

>







|

|







 







|







561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576

577
578
579
580
581
582
583
....
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
....
4481
4482
4483
4484
4485
4486
4487
4488
4489
4490
4491
4492
4493
4494
4495
    #	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
    #
    # 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 callframe} {
	# Construct the call frame itself

	set length [Const [llength $varlist]]
	set locals [my arrayAlloc 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 {}
................................................................................
    }

    # 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 {entryBlock len {name {}}} {
	set type [Type array{bool,$len}]
	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 {entryBlock len {name {}}} {
	set type [Type array{STRING,$len}]
	set strs [my allocInBlock $entryBlock $type ${name}.space]
	set first [my gep $strs 0]
	SetValueName $first $name
	return $first
    }

    # Builder:appendString --
    #
................................................................................
    # Builder:invoke --
    #
    #	Generate code to call a Tcl command.  Quadcode implementation
    #	('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) -

Changes to codegen/compile.tcl.

253
254
255
256
257
258
259

260
261

262
263
264
265
266
267




268
269
270
271
272
273
274
...
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
....
1093
1094
1095
1096
1097
1098
1099

1100

1101
1102
1103
1104
1105
1106
1107
....
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
....
1167
1168
1169
1170
1171
1172
1173



1174
1175
1176
1177
1178
1179
1180
1181

1182
1183
1184
1185
1186
1187
1188
....
1195
1196
1197
1198
1199
1200
1201
1202
1203

1204

1205
1206
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
....
1301
1302
1303
1304
1305
1306
1307



1308
1309
1310
1311
1312
1313
1314
1315
....
1428
1429
1430
1431
1432
1433
1434
1435
1436








1437
1438
1439
1440
1441
1442
1443
....
1448
1449
1450
1451
1452
1453
1454
1455
1456
1457
1458
1459
1460
1461
1462
....
1545
1546
1547
1548
1549
1550
1551

1552
1553
1554
1555




1556
1557
1558
1559
1560
1561
1562
....
2226
2227
2228
2229
2230
2231
2232


2233
2234


2235
2236
2237
2238
2239
2240
2241
	}
	$func setAsCurrentDebuggingScope

	lassign [my GenerateBasicBlocks $quads] blockDict ipathDict pred
	array set block $blockDict
	array set ipath $ipathDict


	# 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]
................................................................................
	    # Issue the code for a single quadcode instruction.
	    #

	    try {
	    $b @location $currentline
	    switch -exact -- [lindex $l 0 0] {
		"entry" {
		    lassign [my IssueEntry $l] \
			theframe thevarmap syntheticargs
		}
		"NRE.entry" {
		    lassign [my IssueEntry $l] \
			theframe thevarmap syntheticargs
		}
		"allocObjvForCallees" {
		    set objc [lindex $l 2 1]
		    if {$objc > 0} {


			set objv [$b allocObjv $objc "objv.for.callees"]

			set bitv [$b allocBitv $objc "flags.for.invokeExpanded"]
		    }
		}
		"confluence" - "unset" {
		    # Do nothing; required for SSA computations only
		}
		"@debug-file" {
		}
................................................................................
	}

	##############################################################
	#
	# Create basic blocks
	#


	set block(-1) [$func block]

	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)]} {
................................................................................

	##############################################################
	#
	# Compute the predecessors of each basic block
	#

	set pc -1
	set pred {}
	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
................................................................................
    # 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.



    #
    # 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} {

	lassign $quad opcode tgt vars

	# When no frame is wanted
	if {$tgt eq {}} {
	    return [list [$b null CALLFRAME] {} {}]
	}

................................................................................
	    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]
	    }
	}


	# 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 alloc [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]


	lassign [$b frame.create $varmeta $argc $argv \
			[$b load $procmeta "proc.metadata"] \
			[$b load $localcache "proc.localcache"]] \

	    theframe thevarmap
	my StoreResult $tgt $theframe
	return [list $theframe $thevarmap $drop]
    }
 
    # TclCompiler:IssueInvoke --
    #
................................................................................
	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}]



	    my IssueNREInvokeFunction $rettype $tgt $called $argvals $vname
	    return {}
	} else {
	    set arguments [linsert $arguments[set arguments ""] 0 $origname]
	    set argvals [lmap arg $arguments {my LoadOrLiteral $arg}]
	    my IssueNREInvokeCommand $rettype $tgt $arguments $argvals $vname
	    return $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]

	# Emit the sequence that destroys the LLVM coroutine and returns the
	# result as 'retval'
	lassign [my returnedFromCoro $rettype $corohandle] \
	    retcode retval









	# Handle the return

	if {$tgttype eq "FAIL"} {
	    # This procedure only ever fails.
	    $b store $retval $errorCode
	    my SetErrorLine $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
................................................................................
    #	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 {rettype tgt func arguments vname} {
	set result [$b call $func $arguments $vname]
	my StoreResult $tgt $result
	$b launchCoroRunner $result




    }
 
    method IssueInvokeCommand {tgt arguments argvals vname} {
	upvar 1 callframe callframe thecallframe thecallframe

	set types [lmap s $arguments {my ValueTypes $s}]

................................................................................
	    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\


	             '[PrintValueToString $value]'\
                     into a variable, '$desc', of type '$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







>
|

>
|


<


>
>
>
>







 







|



|





>
>
|
>
|







 







>
|
>







 







|







 







>
>
>







|
>







 







<
<
>

>
|
|
<
|
|
|
<
>







 







>
|






>


>









>
>

|
|
>







 







>
>
>
|







 







|
|
>
>
>
>
>
>
>
>







 







<







 







>
|

<

>
>
>
>







 







>
>
|
<
>
>







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
...
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
....
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
....
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
....
1177
1178
1179
1180
1181
1182
1183
1184
1185
1186
1187
1188
1189
1190
1191
1192
1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
....
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
....
1320
1321
1322
1323
1324
1325
1326
1327
1328
1329
1330
1331
1332
1333
1334
1335
1336
1337
....
1450
1451
1452
1453
1454
1455
1456
1457
1458
1459
1460
1461
1462
1463
1464
1465
1466
1467
1468
1469
1470
1471
1472
1473
....
1478
1479
1480
1481
1482
1483
1484

1485
1486
1487
1488
1489
1490
1491
....
1574
1575
1576
1577
1578
1579
1580
1581
1582
1583

1584
1585
1586
1587
1588
1589
1590
1591
1592
1593
1594
1595
....
2259
2260
2261
2262
2263
2264
2265
2266
2267
2268

2269
2270
2271
2272
2273
2274
2275
2276
2277
	}
	$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.
	#     block(-1) is the function entry block. It's supposed to be
	# almost entirely optimized out.

	$block(-2) build-in $b
	$b @location 0
	set errorCode [$b alloc int "tcl.errorCode"]

	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]
................................................................................
	    # Issue the code for a single quadcode instruction.
	    #

	    try {
	    $b @location $currentline
	    switch -exact -- [lindex $l 0 0] {
		"entry" {
		    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 $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" {
		}
................................................................................
	}

	##############################################################
	#
	# Create basic blocks
	#

	set block(-2) [$func block]; # Block(-2) is reserved for alloca's
	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)]} {
................................................................................

	##############################################################
	#
	# Compute the predecessors of each basic block
	#

	set pc -1
	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
................................................................................
    # 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 pc entryBlock} {

	lassign $quad opcode tgt vars

	# When no frame is wanted
	if {$tgt eq {}} {
	    return [list [$b null CALLFRAME] {} {}]
	}

................................................................................
	    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 arguments [list [list literal $cmd]]
	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 \
		      [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
	puts "arguments: $arguments argtypes: $argtypes"
	foreach v $arguments t $argtypes {
	    if {[incr idx]} {
		puts "transfer param $idx (type $t) to $v"
		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"] \
		    $callframe] \
	    theframe thevarmap
	my StoreResult $tgt $theframe
	return [list $theframe $thevarmap $drop]
    }
 
    # TclCompiler:IssueInvoke --
    #
................................................................................
	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]
	    return {}
	} else {
	    set arguments [linsert $arguments[set arguments ""] 0 $origname]
	    set argvals [lmap arg $arguments {my LoadOrLiteral $arg}]
	    my IssueNREInvokeCommand $rettype $tgt $arguments $argvals $vname
	    return $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]

	# Emit the sequence that destroys the LLVM coroutine and returns the
	# result as 'retval'
	lassign [my returnedFromCoro $rettype $tgttype $corohandle] \
	    callframe retcode retval
	if 0 {
	    puts "returned from coro:"
	    if {$callframe ne ""} {
		puts " callframe=[PrintValueToString $callframe]"
	    }
	    puts "retcode=[PrintValueToString $retcode]\n\
	          retval=[PrintValueToString $retval]\n"
	}

	# Handle the return

	if {$tgttype eq "FAIL"} {
	    # This procedure only ever fails.
	    $b store $retval $errorCode
	    my SetErrorLine $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
................................................................................
    #	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}]

................................................................................
	    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] \

		[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

Changes to codegen/coro.tcl.

308
309
310
311
312
313
314

315
316
317

318
319
320
321
322
323
324
...
368
369
370
371
372
373
374
375
376
377
378
379





380
381
382
383
384
385
386
...
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
 
# TclCompiler method CoroPromiseType --
#
#	Generates the LLVM type that represents the coroutine promise for
#	the current NRE function

oo::define TclCompiler method CoroPromiseType {{rettype {}}} {

    if {$rettype eq {}} {
	set rettype $returnType
    }

    set typestr named 
    append typestr \{ [nameOfType $rettype] .promise
    append typestr , status:int32
    append typestr , retval: [nameOfType $rettype]
    append typestr \}
    return [Type $typestr]
}
................................................................................
#	rettype - The function's return type
#	callee - The name of the function that has been called
#
# Results:
#	Returns a list of two LLVM value refs: the status code and the
#	return value.

oo::define TclCompiler method returnedFromCoro {rettype corohandle} {

    # Retrieve the coroutine promise from the coroutine handle

    set handle [my LoadOrLiteral $corohandle]





    set ptype [my CoroPromiseType $rettype]
    set alignment [Const [$m alignof $ptype] int32]
    set paddr_raw [$b call [$m intrinsic coro.promise] \
		       [list $handle $alignment [Const false bool]] \
		       "promise.addr.raw"]
    set paddr [$b cast(ptr) $paddr_raw $ptype "promise.addr"]

................................................................................

    # Destroy the coroutine - we're done with it now.

    $b call [$m intrinsic coro.destroy] [list $handle]

    # Return the status and result

    return [list $rcode $rval]
}
 
# TclCompiler method NRReturnToThunk --
#
#	Generates the codeburst to return to a call thunk when a compiled
#	NRE procedure returns.
#







>



>







 







|




>
>
>
>
>







 







|







308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
...
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
...
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
 
# TclCompiler method CoroPromiseType --
#
#	Generates the LLVM type that represents the coroutine promise for
#	the current NRE function

oo::define TclCompiler method CoroPromiseType {{rettype {}}} {
    namespace upvar ::quadcode::dataType CALLFRAME CALLFRAME
    if {$rettype eq {}} {
	set rettype $returnType
    }
    set rettype [expr {$rettype & ~$CALLFRAME}]
    set typestr named 
    append typestr \{ [nameOfType $rettype] .promise
    append typestr , status:int32
    append typestr , retval: [nameOfType $rettype]
    append typestr \}
    return [Type $typestr]
}
................................................................................
#	rettype - The function's return type
#	callee - The name of the function that has been called
#
# Results:
#	Returns a list of two LLVM value refs: the status code and the
#	return value.

oo::define TclCompiler method returnedFromCoro {rettype tgttype corohandle} {

    # Retrieve the coroutine promise from the coroutine handle

    set handle [my LoadOrLiteral $corohandle]
    set frame {}
    if {"CALLFRAME" in $tgttype} {
	set frame [$b frame.frame $handle]
	set handle [$b frame.value $handle]
    }
    set ptype [my CoroPromiseType $rettype]
    set alignment [Const [$m alignof $ptype] int32]
    set paddr_raw [$b call [$m intrinsic coro.promise] \
		       [list $handle $alignment [Const false bool]] \
		       "promise.addr.raw"]
    set paddr [$b cast(ptr) $paddr_raw $ptype "promise.addr"]

................................................................................

    # Destroy the coroutine - we're done with it now.

    $b call [$m intrinsic coro.destroy] [list $handle]

    # Return the status and result

    return [list $frame $rcode $rval]
}
 
# TclCompiler method NRReturnToThunk --
#
#	Generates the codeburst to return to a call thunk when a compiled
#	NRE procedure returns.
#

Changes to codegen/jit.tcl.

191
192
193
194
195
196
197



198
199
200
201
202
203
204
		$module optimize $optimiseLevel
	    }

	    timeit dump-post {
		# Save the current IR
		variable dumpPost [$module dump]
		variable bitcodePost [$module bitcode]



	    }

	    timeit assemble {
		# Call the package init function. This causes native code to
		# be issued and linked.
		$thunkBuilder install
	    }







>
>
>







191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
		$module optimize $optimiseLevel
	    }

	    timeit dump-post {
		# Save the current IR
		variable dumpPost [$module dump]
		variable bitcodePost [$module bitcode]
		set f_ [open opt.ll w]
		puts $f_ $dumpPost
		close $f_
	    }

	    timeit assemble {
		# Call the package init function. This causes native code to
		# be issued and linked.
		$thunkBuilder install
	    }

Changes to codegen/llvmbuilder.tcl.

103
104
105
106
107
108
109





















110
111
112
113
114
115
116
    # Results:
    #	A pointer to the location as an LLVM value reference.

    method alloc {type {name ""}} {
	my @validToIssue
	my Locate [BuildAlloca $b [Type $type] $name]
    }






















    # Builder:and --
    #
    #	Generate code to compute the bitwise-and of two integers of the same
    #	bit width.
    #
    # Parameters:







>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>







103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
    # Results:
    #	A pointer to the location as an LLVM value reference.

    method alloc {type {name ""}} {
	my @validToIssue
	my Locate [BuildAlloca $b [Type $type] $name]
    }

    # Builder:allocInBlock --
    #
    #	Generates an 'alloca' instruction, but puts it in a block other than
    #	the current one.
    #
    # Parameters:
    #	block - Block to place the alloc
    #	type - LLVM type reference of the type to allocate
    #	name - Name to assign to the result
    #
    # Results:
    #	Returns a LLVM value reference to the pointer to the allocated space

    method allocInBlock {block type name} {
	set here [my @cur]
	my @end $block
	set ref [my alloc $type $name]
	my @end $here
	return $ref
    }

    # Builder:and --
    #
    #	Generate code to compute the bitwise-and of two integers of the same
    #	bit width.
    #
    # Parameters:

Changes to codegen/thunk.tcl.

192
193
194
195
196
197
198


199
200
201
202
203
204
205
	}
	my buildInSection packageProvide {
	    set block [$metathunk block leave]
	    $metathunkblock build $b {
		$b br $block
	    }
	    $block build $b {


		if {$version ne ""} {
		    set pkgname tclquadcoded::[string trimleft [$m name] ":"]
		    $b ret [my Tcl_PkgProvideEx $interp \
			    [$b constString $pkgname "pkg.name"] \
			    [$b constString $version "pkg.version"] {}]
		} else {
		    $b ret $OK







>
>







192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
	}
	my buildInSection packageProvide {
	    set block [$metathunk block leave]
	    $metathunkblock build $b {
		$b br $block
	    }
	    $block build $b {
		set llvm.debugtrap [$m intrinsic debugtrap]
		$b call ${llvm.debugtrap} {}
		if {$version ne ""} {
		    set pkgname tclquadcoded::[string trimleft [$m name] ":"]
		    $b ret [my Tcl_PkgProvideEx $interp \
			    [$b constString $pkgname "pkg.name"] \
			    [$b constString $version "pkg.version"] {}]
		} else {
		    $b ret $OK

Changes to demos/perftest/tester.tcl.

1281
1282
1283
1284
1285
1286
1287





















1288
1289
1290
1291
1292
1293
1294
....
2211
2212
2213
2214
2215
2216
2217

2218

2219
2220
2221
2222
2223
2224
2225
....
2413
2414
2415
2416
2417
2418
2419





2420
2421
2422
2423
2424
2425
2426
    if {$n == 0} {
	return -code error "Error thrown from recursive proc"
    } else {
	return .[rectest2 [expr {$n-1}]]
    }
}























proc qsort {L {left 0} {right -1}} {
    set left [expr {int($left)}]
    set right [expr {int($right)}]
    if {$right < 0} {set right [expr {[llength $L] - 1}]}
    set pivot [lindex $L [expr {($left + $right) / 2}]]

................................................................................

    {bug-0616bcf08e::msrange 0 10}
    {bug-0616bcf08e::msrange2 0 10}
    {singleton::lforeach}
    {singleton::llindex}
    {singleton::srange}
    {rectest1}

    {list [catch rectest2 result] $result}

    {qsort {3 6 8 7 0 1 4 2 9 5}}
    {impure 0x0 0 0}
    {impure 0x3 0 0}
    {impure 0 1 1}
    {impure 10 10000 10}
    {impure 1 +2000 [string range "123" 2 2]}
    {impure-typecheck-int 10 10000 10}
................................................................................
    expandtest::test12

    # Combined feature tests
    lcmRange
    bug-0616bcf08e::*
    rectest1
    rectest2





    qsort
    impure
    impure-caller
    impure-typecheck-int
    impure2
    comps
    bug-7c599d4029::*







>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>







 







>

>







 







>
>
>
>
>







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
1312
1313
1314
1315
....
2232
2233
2234
2235
2236
2237
2238
2239
2240
2241
2242
2243
2244
2245
2246
2247
2248
....
2436
2437
2438
2439
2440
2441
2442
2443
2444
2445
2446
2447
2448
2449
2450
2451
2452
2453
2454
    if {$n == 0} {
	return -code error "Error thrown from recursive proc"
    } else {
	return .[rectest2 [expr {$n-1}]]
    }
}

proc rectest3 {nv} {
    upvar 1 $nv n
    if {[incr n -1] <= 0} {
	return |
    } else {
	return .[rectest3 n]
    }
}

proc treecollect {t} {
    set l {}
    treewalk l $t
    return $l
}
proc treewalk {lvar t} {
    upvar 1 $lvar l
    lappend l [lindex $t 0]
    foreach item [lrange $t 1 end] {
	treewalk l $item
    }
}

proc qsort {L {left 0} {right -1}} {
    set left [expr {int($left)}]
    set right [expr {int($right)}]
    if {$right < 0} {set right [expr {[llength $L] - 1}]}
    set pivot [lindex $L [expr {($left + $right) / 2}]]

................................................................................

    {bug-0616bcf08e::msrange 0 10}
    {bug-0616bcf08e::msrange2 0 10}
    {singleton::lforeach}
    {singleton::llindex}
    {singleton::srange}
    {rectest1}
    {treecollect {a {b {d {h i}} {e {j k}}} {c {f {l m}} {g {n o}}}}}
    {list [catch rectest2 result] $result}
    {set x 3; rectest3 x}
    {qsort {3 6 8 7 0 1 4 2 9 5}}
    {impure 0x0 0 0}
    {impure 0x3 0 0}
    {impure 0 1 1}
    {impure 10 10000 10}
    {impure 1 +2000 [string range "123" 2 2]}
    {impure-typecheck-int 10 10000 10}
................................................................................
    expandtest::test12

    # Combined feature tests
    lcmRange
    bug-0616bcf08e::*
    rectest1
    rectest2
    rectest3
    # treecollect   Not working - upvar in NRE proc
    treecollect
    # treewalk      Not working - upvar in NRE proc
    treewalk
    qsort
    impure
    impure-caller
    impure-typecheck-int
    impure2
    comps
    bug-7c599d4029::*

Changes to quadcode/nre.tcl.

77
78
79
80
81
82
83



84
85
86
87
88
89
90
...
132
133
134
135
136
137
138

139
140
141
142
143
144
145
146
147
148
149
150
#	'entry' is replaced with 'entryNRE'. 'return' is replaced with
#	'returnNRE'. 'invoke' is more complex. It causes the basic block
#	to be split with an unconditional jump immediately following the
#	'invoke', and the 'invoke' to be replaced with 'invokeNRE'.

oo::define quadcode::transformer method promoteNREOperations {} {




    my debug-nre {
	puts "Before NRE promotion: "
	my dump-bb
    }

    set bbcount [llength $bbcontent]
    for {set bbno 0} {$bbno < $bbcount} {incr bbno} {
................................................................................
			    typeOfOperand $types $a
			}]
			set usenre [$specializer nreRequired $q $atypes]
		    }

		    if {$usenre} {
			set resultv [lindex $q 1]

			lset q 0 [list NRE.$opcode [dict get $types $resultv]]
			set coroHandle [my newVarInstance $resultv]
			lset q 1 $coroHandle
			dict set types $coroHandle \
			    $::quadcode::dataType::COROHANDLE
			my debug-nre {
			    puts "$b:[llength $newbb]: $q"
			}
			my bbEmitAndTrack $b newbb $q
			set continuation [my bbCreate]
			my debug-nre {
			    puts "$b:[llength $newbb]: \







>
>
>







 







>




|







77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
...
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
#	'entry' is replaced with 'entryNRE'. 'return' is replaced with
#	'returnNRE'. 'invoke' is more complex. It causes the basic block
#	to be split with an unconditional jump immediately following the
#	'invoke', and the 'invoke' to be replaced with 'invokeNRE'.

oo::define quadcode::transformer method promoteNREOperations {} {

    namespace upvar ::quadcode::dataType \
        COROHANDLE COROHANDLE CALLFRAME CALLFRAME

    my debug-nre {
	puts "Before NRE promotion: "
	my dump-bb
    }

    set bbcount [llength $bbcontent]
    for {set bbno 0} {$bbno < $bbcount} {incr bbno} {
................................................................................
			    typeOfOperand $types $a
			}]
			set usenre [$specializer nreRequired $q $atypes]
		    }

		    if {$usenre} {
			set resultv [lindex $q 1]
                        set inty [typeOfOperand $types $cfin]
			lset q 0 [list NRE.$opcode [dict get $types $resultv]]
			set coroHandle [my newVarInstance $resultv]
			lset q 1 $coroHandle
			dict set types $coroHandle \
			    [expr {$COROHANDLE | ($inty & $CALLFRAME)}]
			my debug-nre {
			    puts "$b:[llength $newbb]: $q"
			}
			my bbEmitAndTrack $b newbb $q
			set continuation [my bbCreate]
			my debug-nre {
			    puts "$b:[llength $newbb]: \

Changes to quadcode/types.tcl.

339
340
341
342
343
344
345
346
347
348
349

350
351
352
353
354
355
356
...
689
690
691
692
693
694
695
696

697
698
699
700
701
702
703
    if {$type == 0} {
	return NOTHING
    }

    set result {}

    foreach {name wname} {
	COROHANDLE		COROHANDLE
	CALLFRAME		CALLFRAME
	NEXIST			NEXIST
	FAIL			FAIL

	ARRAY			ARRAY
	DICTITER		DICTITER
	FOREACH			FOREACH
	EXPANDED		EXPANDED
	OTHERSTRING		STRING
	IMPURE			IMPURE
	EMPTY			EMPTY
................................................................................
	    } else {
		set rtype [expr {$FAIL | $STRING}]
	    }
	    set inty [typeOfOperand $types [lindex $q 2]]
	    return [expr {($inty & $CALLFRAME) | $rtype}]
	}
	"NRE.invoke" {
	    return $COROHANDLE

	}
	invokeExpanded {
	    # We can eliminate callframe in a smaller set of cases than
	    # with 'invoke' - but punt for now.
	    set inty [typeOfOperand $types [lindex $q 2]]
	    return [expr {($inty & $CALLFRAME) | $FAIL | $STRING}]
	}







<



>







 







|
>







339
340
341
342
343
344
345

346
347
348
349
350
351
352
353
354
355
356
...
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
    if {$type == 0} {
	return NOTHING
    }

    set result {}

    foreach {name wname} {

	CALLFRAME		CALLFRAME
	NEXIST			NEXIST
	FAIL			FAIL
	COROHANDLE		COROHANDLE
	ARRAY			ARRAY
	DICTITER		DICTITER
	FOREACH			FOREACH
	EXPANDED		EXPANDED
	OTHERSTRING		STRING
	IMPURE			IMPURE
	EMPTY			EMPTY
................................................................................
	    } else {
		set rtype [expr {$FAIL | $STRING}]
	    }
	    set inty [typeOfOperand $types [lindex $q 2]]
	    return [expr {($inty & $CALLFRAME) | $rtype}]
	}
	"NRE.invoke" {
	    set inty [typeOfOperand $types [lindex $q 2]]
	    return [expr {$COROHANDLE | ($inty & $CALLFRAME)}]
	}
	invokeExpanded {
	    # We can eliminate callframe in a smaller set of cases than
	    # with 'invoke' - but punt for now.
	    set inty [typeOfOperand $types [lindex $q 2]]
	    return [expr {($inty & $CALLFRAME) | $FAIL | $STRING}]
	}