Check-in [ab703b4b95]
Bounty program for improvements to Tcl and certain Tcl packages.
Tcl 2019 Conference, Houston/TX, US, Nov 4-8
Send your abstracts to [email protected]
or submit via the online form by Sep 9.

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

Overview
Comment:Finish coding the thunk builder for NRE procs. Generated code for NRE now aborts in the optimizer.
Timelines: family | ancestors | descendants | both | notworking | kbk-nre
Files: files | file ages | folders
SHA3-256: ab703b4b95b555e2b2e8a1148eab29d8309ee39b878b838f3f8aa5b6688610b0
User & Date: kbk 2018-04-15 03:07:26
Context
2018-04-16
01:09
Merge trunk to get better handling of 'phi' operations. Fix issues that prevented compilability with these changes. check-in: bc9590bbdb user: kbk tags: notworking, kbk-nre
2018-04-15
03:07
Finish coding the thunk builder for NRE procs. Generated code for NRE now aborts in the optimizer. check-in: ab703b4b95 user: kbk tags: notworking, kbk-nre
2018-04-14
22:10
Finish up return from an invoked function. Still need to do invoked commands and invokeExpanded in the NRE case. check-in: 2b2ba21e34 user: kbk tags: notworking, kbk-nre
Changes

Changes to codegen/build.tcl.

9
10
11
12
13
14
15

16
17
18
19
20
21
22
#
# 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






>







9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
#
# 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

Changes to codegen/compile.tcl.

201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
...
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
...
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
....
1394
1395
1396
1397
1398
1399
1400
1401
1402
1403
1404
1405
1406
1407
1408
1409
1410
1411
1412
1413
....
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
....
2560
2561
2562
2563
2564
2565
2566

2567
2568
2569
2570
2571












2572
2573
2574
2575
2576
2577
2578
2579
		}
		"NRE.entry" {
		    set nreReturnType [nameOfType $returnType]
		    break
		}
	    }
	}
	puts "Type of $cmd is $rtype"
	set returntype [Type $rtype]

	##############################################################
	#
	# Construct the function signature type and the function object.
	#

................................................................................
	    }
	    set variables($name) [$b load $undefs($type) "undef.$formalname"]
	}

	foreach insn $quads {
	    switch -exact -- [lindex $insn 0 0] {
		"NRE.entry" {
		    puts "$cmd: $insn"
		    set coro_info \
			[my IssueNREEntrySequence $curr_block $block(0)]
		    set curr_block $block(0)
		    break
		}
		"entry" {
		    break
................................................................................
		    if {$theframe ne "" && ![IsNull $theframe]} {
			$b frame.release $theframe $syntheticargs
		    }
		    $b ret $val
		}
		"NRE.return" {
		    lassign $l opcode -> frame src
		    puts "src is $src"
		    puts "src type is [my ValueTypes $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]
		    puts "return type is $type"
		    if {refType($type)} {
			$b printref $val "ret:"
			if {literal($src)} {
			    $b addReference($type) $val
			}
		    }
		    if {$theframe ne "" && ![IsNull $theframe]} {
................................................................................

    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]
	puts "IssueNREReturnFromInvoke:"
	puts "  tgt = $tgt"
	puts "  rettype = $rettype = [nameOfType $rettype]"
	puts "  origname = $origname"
	puts "  vname = $vname"
	puts "  called = $called"
	if {$called ne {}} {
	    my IssueNREReturnFromInvokedFunction \
		$rettype $tgt $corohandle $callframe $called $arguments $vname
	    return {}
	} else {
	    set arguments [linsert $arguments[set arguments ""] 0 $origname]
	    set i -1
................................................................................

	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
	    puts "Result type is $restype and target type is $tgttype"
	    puts "How could they be different?"
	    if {$restype in $ts} {
		puts "The called function returns a known type"
		$b store [$b extract $retval 0] $errorCode
	    } elseif {[Type $restype?] eq [Type $tgttype]} {
		puts "The called function returns a MAYBE"
		set retval [$b ok $reval]
	    }
	    if {"FAIL" in $tgttype} {
		puts "Result might have failed, set error line"
		my SetErrorLine $errorCode [$b maybe $retval]
	    }
	}

	# Pack a callframe reference with the return if needed

	if {"CALLFRAME" in $tgttype} {
	    puts "Result includes an updated callframe"
	    set result [$b frame.pack $callframe $result]
	}
    }
 
    # TclCompiler:ResolveInvoke --
    #
    #	Determines whether an invoked command is known as a compiled
................................................................................
    #		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} {

	if {[dict exists $bytecode procmeta]} {
	    $thunkBuilder buildProcedureMetadata $cmd $bytecode \
		[dict get $bytecode procmeta]
	    dict unset bytecode procmeta
	}












	$thunkBuilder thunk $cmd $bytecode $func
    }

    # TclInterproceduralCompiler:printTypedQuads --
    #
    #	Print the sequence of typed quadcodes that the type inference engine
    #	has transformed the procedure into.
    #






<







 







<







 







<
<






<







 







<
<
<
<
<
<







 







<
<

<


<



<







<







 







>





>
>
>
>
>
>
>
>
>
>
>
>
|







201
202
203
204
205
206
207

208
209
210
211
212
213
214
...
321
322
323
324
325
326
327

328
329
330
331
332
333
334
...
817
818
819
820
821
822
823


824
825
826
827
828
829

830
831
832
833
834
835
836
....
1389
1390
1391
1392
1393
1394
1395






1396
1397
1398
1399
1400
1401
1402
....
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
....
2543
2544
2545
2546
2547
2548
2549
2550
2551
2552
2553
2554
2555
2556
2557
2558
2559
2560
2561
2562
2563
2564
2565
2566
2567
2568
2569
2570
2571
2572
2573
2574
2575
		}
		"NRE.entry" {
		    set nreReturnType [nameOfType $returnType]
		    break
		}
	    }
	}

	set returntype [Type $rtype]

	##############################################################
	#
	# Construct the function signature type and the function object.
	#

................................................................................
	    }
	    set variables($name) [$b load $undefs($type) "undef.$formalname"]
	}

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

    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]






	if {$called ne {}} {
	    my IssueNREReturnFromInvokedFunction \
		$rettype $tgt $corohandle $callframe $called $arguments $vname
	    return {}
	} else {
	    set arguments [linsert $arguments[set arguments ""] 0 $origname]
	    set i -1
................................................................................

	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 $reval]
	    }
	    if {"FAIL" in $tgttype} {

		my SetErrorLine $errorCode [$b maybe $retval]
	    }
	}

	# Pack a callframe reference with the return if needed

	if {"CALLFRAME" in $tgttype} {

	    set result [$b frame.pack $callframe $result]
	}
    }
 
    # TclCompiler:ResolveInvoke --
    #
    #	Determines whether an invoked command is known as a compiled
................................................................................
    #		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 $isNRE [nameOfType $returnType]
    }

    # TclInterproceduralCompiler:printTypedQuads --
    #
    #	Print the sequence of typed quadcodes that the type inference engine
    #	has transformed the procedure into.
    #

Changes to codegen/coro.tcl.

13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
...
114
115
116
117
118
119
120













121
122
123
124
125
126
127
...
247
248
249
250
251
252
253

254
255
256
257
258
259
260
...
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
...
339
340
341
342
343
344
345































346
347
348
349
350
351
352
oo::define Builder {

    # Implementation of various support functions needed to support Tcl's
    # coroutines

    variable tcl.coro.runner
    variable tcl.coro.addCallbackToCoroRunner

}
 
# Builder method @coroFunctions --
#
#	Defines support functions for LLVM coroutines that need to be in
#	LLVM assembly language.
#
................................................................................

	$api Tcl_NRAddCallback [$api tclInterp] ${tcl.coro.runner} $coroHandle \
	    [my null char*] [my null char*] [my null char*]
	my ret

    }














}
 
# TclCompiler method IssueNREEntrySequence --
#
#	Issues the sequence of code that begins an LLVM coroutine
#	that corresponds to an NRE Tcl procedure.
#
................................................................................
			    "coro.frame.need.to.free"]
    $b condBr $coro_need_free $free_frame $suspend

    $free_frame build-in $b
    $b @location 0

    $b Tcl_Free $coro_frame


    # All exits from the coroutine, whether because it has finished,
    # suspended, or been killed, come here to return.

    $suspend build-in $b
    $b @location 0

................................................................................
    set typestr named 
    append typestr \{ $realname .promise
    append typestr , status:int32
    append typestr , retval: [nameOfType $rettype]
    append typestr \}
    return [Type $typestr]
}


 
# Builder method launchCoroRunner --
#
#	Generates code to launch the Tcl_NRAddCallback chain that executes
#	the LLVM coroutine representing a Tcl command invocation.
#
# Parameters:
#	handle - LLVM value reference specifying the LLVM coroutine handle

oo::define Builder method launchCoroRunner {handle} {
    my call ${tcl.coro.addCallbackToCoroRunner} $handle
}
 
























# TclCompiler method returnFromCoro --
#
#	Generates code to retrieve the status and return value from
#	a coroutine that has done the final suspend.
#
# Parameters:
#	rettype - The function's return type
................................................................................
    $b call [$m intrinsic coro.destroy] [list $handle]

    # Return the status and result

    return [list $rcode $rval]
}
 































# TclCompiler method CoroSuspend --
#
#	Generates code to suspend the current coroutine and resume at a
#	specified basic block.
#
# Parameters:
#	coro_info - Information about the current LLVM coroutine from






|







 







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







 







>







 







>
>













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







 







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







13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
...
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
...
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
...
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
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
...
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
oo::define Builder {

    # Implementation of various support functions needed to support Tcl's
    # coroutines

    variable tcl.coro.runner
    variable tcl.coro.addCallbackToCoroRunner
    variable tcl.nr.add.callback
}
 
# Builder method @coroFunctions --
#
#	Defines support functions for LLVM coroutines that need to be in
#	LLVM assembly language.
#
................................................................................

	$api Tcl_NRAddCallback [$api tclInterp] ${tcl.coro.runner} $coroHandle \
	    [my null char*] [my null char*] [my null char*]
	my ret

    }

    ##### Function: tcl.nr.add.callback #####
    #
    # Type signature: NRCallback*×char*×char*×char*×char*->void
    #
    # Adds a callback to the Tcl interpreter
    
    set f [$m local tcl.nr.add.callback \
	       void<-func{int<-ClientData*,Interp*,int}*,char*,char*,char*,char*]
    params func d1 d2 d3 d4
    build {
	$api Tcl_NRAddCallback [$api tclInterp] $func $d1 $d2 $d3 $d4
	my ret
    }
}
 
# TclCompiler method IssueNREEntrySequence --
#
#	Issues the sequence of code that begins an LLVM coroutine
#	that corresponds to an NRE Tcl procedure.
#
................................................................................
			    "coro.frame.need.to.free"]
    $b condBr $coro_need_free $free_frame $suspend

    $free_frame build-in $b
    $b @location 0

    $b Tcl_Free $coro_frame
    $b br $suspend

    # All exits from the coroutine, whether because it has finished,
    # suspended, or been killed, come here to return.

    $suspend build-in $b
    $b @location 0

................................................................................
    set typestr named 
    append typestr \{ $realname .promise
    append typestr , status:int32
    append typestr , retval: [nameOfType $rettype]
    append typestr \}
    return [Type $typestr]
}
 

 
# Builder method launchCoroRunner --
#
#	Generates code to launch the Tcl_NRAddCallback chain that executes
#	the LLVM coroutine representing a Tcl command invocation.
#
# Parameters:
#	handle - LLVM value reference specifying the LLVM coroutine handle

oo::define Builder method launchCoroRunner {handle} {
    my call ${tcl.coro.addCallbackToCoroRunner} $handle
}
 
# Builder method NRAddCallback --
#
#	Add a callback to the current interpreter
#
# Parameters:
#	func - LLVM reference to the callback function
#	args - LLVM references to up to four client data objects
#
# Results:
#	None.

oo::define Builder method NRAddCallback {func args} {
    set argv {}
    if {[llength $args] > 4} {
	error "at most four client data objects can be passed to a callback"
    }
    set argv [lmap a $args {my cast(ptr) $a int8}]
    while {[llength $argv] < 4} {
	lappend argv [my null int8*]
    }
    my call ${tcl.nr.add.callback} [linsert $argv 0 $func]
}
oo::define Builder export NRAddCallback
 
# TclCompiler method returnFromCoro --
#
#	Generates code to retrieve the status and return value from
#	a coroutine that has done the final suspend.
#
# Parameters:
#	rettype - The function's return type
................................................................................
    $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.
#
# Parameters:
#	handle - LLVM value reference to the LLVM coroutine for the
#		 wrapped function invocation
#	restype - Type of the result that is stored in the coroutine promise
#
# Results:
#	Returns the LLVM value reference to the result of the wrapped function

oo::define Builder method NRReturnToThunk {handle resType} {
    puts "Emit return to the thunk"
    set llvm.coro.promise [$m intrinsic coro.promise]
    set promiseAddrRaw [my call ${llvm.coro.promise} \
			    [list $handle \
				 [my cast(int) [AlignOf [Type STRING]]] \
				 [Const false bool]] "promise.addr.raw"]
    set promiseType named{$resType.promise,int32,$resType}
    set promiseAddr [my cast(ptr) $promiseAddrRaw $promiseType]
    set value [my load [my gep $promiseAddr 0 1] "value"]
    puts "Value is of type [PrintTypeToString [TypeOf $value]]"
    set llvm.coro.destroy [$m intrinsic coro.destroy]
    my call ${llvm.coro.destroy} $handle
    puts "Returned to the thunk"
    return $value
}
oo::define Builder export NRReturnToThunk
 
# TclCompiler method CoroSuspend --
#
#	Generates code to suspend the current coroutine and resume at a
#	specified basic block.
#
# Parameters:
#	coro_info - Information about the current LLVM coroutine from

Changes to codegen/struct.tcl.

38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
...
467
468
469
470
471
472
473


474
475
476
477
478
479
480
    superclass llvmEntity
    variable module counter funcs builder myname globals externs engine
    variable dbty mainNS thunkNS initFunction dbbuild

    constructor {name {filename "/dev/null"}} {
	next
	variable ::LLVM::debugmeta
#	set status [ParseCommandLineOptions\
#			-debug-pass=Structure]
#	puts "status = $status"

	set myname $name
	set module [ModuleCreateWithName $name]
	SetTarget $module [GetHostTriple]

	if {$debugmeta} {
................................................................................
	    PassManagerBuilderPopulateModulePassManager $bld $pm
	    PassManagerBuilderPopulateFunctionPassManager $bld $fpm

	    InitializeFunctionPassManager $fpm
	    for {set fn [GetFirstFunction $module]} \
		{$fn ne ""} \
		{set fn [GetNextFunction $fn]} {


		    RunFunctionPassManager $fpm $fn
		}
	    FinalizeFunctionPassManager $fpm
	    RunPassManager $pm $module
	} finally {
	    DisposePassManager $fpm
	    DisposePassManager $pm






|
|







 







>
>







38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
...
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
    superclass llvmEntity
    variable module counter funcs builder myname globals externs engine
    variable dbty mainNS thunkNS initFunction dbbuild

    constructor {name {filename "/dev/null"}} {
	next
	variable ::LLVM::debugmeta
#	set status [ParseCommandLineOptions -print-before-all -time-passes]
#		Had also tried:		-debug-pass=Structure
#	puts "status = $status"

	set myname $name
	set module [ModuleCreateWithName $name]
	SetTarget $module [GetHostTriple]

	if {$debugmeta} {
................................................................................
	    PassManagerBuilderPopulateModulePassManager $bld $pm
	    PassManagerBuilderPopulateFunctionPassManager $bld $fpm

	    InitializeFunctionPassManager $fpm
	    for {set fn [GetFirstFunction $module]} \
		{$fn ne ""} \
		{set fn [GetNextFunction $fn]} {
		    VerifyFunction $fn LLVMPrintMessageAction
#		    DumpValue $fn
		    RunFunctionPassManager $fpm $fn
		}
	    FinalizeFunctionPassManager $fpm
	    RunPassManager $pm $module
	} finally {
	    DisposePassManager $fpm
	    DisposePassManager $pm

Changes to codegen/thunk.tcl.

26
27
28
29
30
31
32

33
34
35
36
37
38
39
..
43
44
45
46
47
48
49


50
51
52
53
54
55
56
...
122
123
124
125
126
127
128


129
130
131
132
133
134
135
136
137
138
139
140
141
142
143





144
145

146
147
148
149
150
151
152
...
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
...
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
...
436
437
438
439
440
441
442


443
444
445
446
447
448
449
...
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
oo::class create ThunkBuilder {
    superclass BuildSupport
    variable m b metathunk metathunkblock metathunkerror metathunkref
    variable makingThunks thunkprocmeta
    variable 0 1 OK ERROR
    variable Tcl_UniChar mp_int Tcl_ObjCmdType Tcl_ObjCmdPtr

    variable Tcl_CmdDeleteProc Tcl_CmdDeletePtr
    variable tcl.obj.constant

    constructor {module} {
	next [set b [$module builder]]
	variable obj.constants.pending {}
	set m $module
................................................................................
	set thunkprocmeta {}

	set Tcl_CmdDeleteProc [Type func{void<-ClientData}]
	set Tcl_CmdDeletePtr [Type $Tcl_CmdDeleteProc*]
	set Tcl_UniChar [Int16Type]
	set Tcl_ObjCmdType [Type func{int<-ClientData,Interp*,int,Tcl_Obj**}]
	set Tcl_ObjCmdPtr [Type $Tcl_ObjCmdType*]


	oo::objdefine $b export Call
	my InitTclMathfuncs

	set name "[$module name]_Init"
	set metathunk [$module function.create $name func{int<-Interp*}]
	my buildInSection preface {
	    [$metathunk block "enter"] build-in $b
................................................................................
    #
    # Parameters:
    #	name -	The name of the command to create.
    #	func -	The LLVM value reference to the function that implements the
    #		command. NOTE that this function has to follow the
    #		Tcl_ObjCmdProc type signature; this does not bind the output
    #		of the code generator directly.


    #
    # Results:
    #	None.

    method InstallCommand {name func} {
	my variable interp
	my buildInSection commands {
	    $metathunkblock build-in $b
	    if {!$makingThunks} {
		set metathunkblock [$metathunk block createCommands]
		$b br $metathunkblock
		set makingThunks 1
		$metathunkblock build-in $b
	    }
	    set namestr [$b constString $name "name.thunk$name"]





	    set result [my Tcl_CreateObjCommand $interp $namestr [$func ref] \
			{} {}]

	    if {[dict exists $thunkprocmeta $name]} {
		set proc [dict get $thunkprocmeta $name]
		$b storeInStruct $proc Proc.cmdPtr $result
	    }
	    set metathunkblock [$metathunk block createCommands]
	    $b condBr [$b nonnull $result] $metathunkblock $metathunkerror
	}
................................................................................
    # Parameters:
    #	name -	The (fully-qualified) name of the Tcl command to generate.
    #	bytecode -
    #		The bytecode description dictionary that describes the
    #		original command. This is an augmented output of the
    #		[tcl::unsupported::getbytecode] command.
    #	func -	The TclOO handle to the function we are binding to.


    #
    # Results:
    #	The function object for the wrapping function.

    method thunk {name bytecode func} {


	set thunk [$m function.create cmd.thunk$name $Tcl_ObjCmdType]
	$thunk private
	$thunk setAsCurrentDebuggingScope

















	set idx -1
	set block [$thunk block]


	$block build-in $b
	$b @location 1



	foreach paramName {clientData interp argc argv} {
	    set $paramName [$thunk param [incr idx] $paramName]
	}
	lassign [dict get $bytecode signature] restype argtypes
	set defaults [dict get $bytecode argumentDefaults]
	set argsIdx -1
	if {"args" eq [lindex $defaults end 0]} {
	    set argsIdx [llength $defaults]
	}

	my CheckArgcInRange $name $interp $argc $argv $defaults $argsIdx



	$b @location 2

	set realargs {}
	set idx 0
	foreach arginfo $defaults {
	    lassign $arginfo argName argDefaulted argDefault
	    incr idx
	    if {$argsIdx >= 0 && $idx >= $argsIdx} {
		set 0 [Const 0]
................................................................................
	    $b assume [$b gt [$b refCount $val] [Const 0]]
	    lappend realargs $val
	    if {[info exists argsToClear]} {
		break
	    }
	}

	$b @location 3


	set value [$b call [$func ref] $realargs "value"]
	SetTailCall $value 0





	$b @location 4

	if {[info exists argsToClear]} {
	    my Tcl_DecrRefCount $argsToClear
	}














	my MapResultToTcl $interp $value $restype

	$b @loc {}





	$thunk verify
	my InstallCommand $name $thunk

	return $thunk
    }


























    # ThunkBuilder:CheckArgcInRange --
    #
    #	Generate code to test whether the argument count to a command
    #	implementation matches that which is required for calling the
    #	function.
    #
................................................................................

    # ThunkBuilder:MapResultToTcl --
    #
    #	Generate code to create a Tcl value that represents the output of a
    #	function.
    #
    # Parameters:


    #	interp -
    #		The LLVM value reference to the Interp*.
    #	result -
    #		The LLVM value reference to the result of the wrapped
    #		function.
    #	resultType -
    #		The human-readable type descriptor for the result of the
................................................................................
    #		wrapped function. Note that this cannot be deduced from the
    #		value itself; some Tcl logical types may be convergently
    #		mapped at the LLVM level.
    #
    # Results:
    #	None.

    method MapResultToTcl {interp result resultType} {
	upvar 1 thunk thunk
	# This only happens when all paths are failing paths
	if {$resultType in {"VOID FAIL" FAIL}} {
	    $b ret $result
	    return
	}
	if {[string match "FAIL *" $resultType]} {
	    # If a failure happened, the error message will have already been






>







 







>
>







 







>
>




|










>
>
>
>
>
|
|
>







 







>
>




|
>
>


<
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>


<
>

<

>
>









<


>
>

<







 







|

>


>
>
>
>






>
>
>
>
>
>
>
>
>
>
>
>
>
>
|
>


>
>
>
>

|
>


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







 







>
>







 







|
|







26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
..
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
...
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
...
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
337
338
339
340
341
342
343
344
345
346

347
348
349
350
351

352
353
354
355
356
357
358
...
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
...
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
...
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
oo::class create ThunkBuilder {
    superclass BuildSupport
    variable m b metathunk metathunkblock metathunkerror metathunkref
    variable makingThunks thunkprocmeta
    variable 0 1 OK ERROR
    variable Tcl_UniChar mp_int Tcl_ObjCmdType Tcl_ObjCmdPtr
    variable Tcl_NRPostProcType Tcl_NRPostProcPtr
    variable Tcl_CmdDeleteProc Tcl_CmdDeletePtr
    variable tcl.obj.constant

    constructor {module} {
	next [set b [$module builder]]
	variable obj.constants.pending {}
	set m $module
................................................................................
	set thunkprocmeta {}

	set Tcl_CmdDeleteProc [Type func{void<-ClientData}]
	set Tcl_CmdDeletePtr [Type $Tcl_CmdDeleteProc*]
	set Tcl_UniChar [Int16Type]
	set Tcl_ObjCmdType [Type func{int<-ClientData,Interp*,int,Tcl_Obj**}]
	set Tcl_ObjCmdPtr [Type $Tcl_ObjCmdType*]
	set Tcl_NRPostProcType [Type func{int<-char**,Interp*,int}]
	set Tcl_NRPostProcPTr [Type $Tcl_NRPostProcType]
	oo::objdefine $b export Call
	my InitTclMathfuncs

	set name "[$module name]_Init"
	set metathunk [$module function.create $name func{int<-Interp*}]
	my buildInSection preface {
	    [$metathunk block "enter"] build-in $b
................................................................................
    #
    # Parameters:
    #	name -	The name of the command to create.
    #	func -	The LLVM value reference to the function that implements the
    #		command. NOTE that this function has to follow the
    #		Tcl_ObjCmdProc type signature; this does not bind the output
    #		of the code generator directly.
    #	wrapper - If non-empty, 'func' is an NR command proc, and 'wrapper'
    #	          is the wrapper function for non-NRE evaluation.
    #
    # Results:
    #	None.

    method InstallCommand {name func wrapper} {
	my variable interp
	my buildInSection commands {
	    $metathunkblock build-in $b
	    if {!$makingThunks} {
		set metathunkblock [$metathunk block createCommands]
		$b br $metathunkblock
		set makingThunks 1
		$metathunkblock build-in $b
	    }
	    set namestr [$b constString $name "name.thunk$name"]
	    if {$wrapper ne ""} {
		my Print [Const "Install NRE command: $namestr" STRING]
		set result [my Tcl_NRCreateCommand $interp $namestr \
				[$wrapper ref] [$func ref] {} {}]
	    } else {
		set result [my Tcl_CreateObjCommand $interp $namestr \
				[$func ref] {} {}]
	    }
	    if {[dict exists $thunkprocmeta $name]} {
		set proc [dict get $thunkprocmeta $name]
		$b storeInStruct $proc Proc.cmdPtr $result
	    }
	    set metathunkblock [$metathunk block createCommands]
	    $b condBr [$b nonnull $result] $metathunkblock $metathunkerror
	}
................................................................................
    # Parameters:
    #	name -	The (fully-qualified) name of the Tcl command to generate.
    #	bytecode -
    #		The bytecode description dictionary that describes the
    #		original command. This is an augmented output of the
    #		[tcl::unsupported::getbytecode] command.
    #	func -	The TclOO handle to the function we are binding to.
    #	nre -   Flag that is true iff the function requires NRE
    #	returnType - LLVM type reference for the return type of the function
    #
    # Results:
    #	The function object for the wrapping function.

    method thunk {name bytecode func nre returnType} {

	# Make the thunk function
	set thunk [$m function.create cmd.thunk$name $Tcl_ObjCmdType]
	$thunk private


	# If the command requires NRE, make the post-processing function
	# and the Obj command proc
	if {$nre} {
	    set thunk2 [$m function.create cmd.thunk2$name \
			    $Tcl_NRPostProcType]
	    $thunk2 private
	    set thunk3 [$m function.create cmd.thunk3$name \
			    $Tcl_ObjCmdType]

	    my MakeObjCmdForNR $b $thunk3 [$thunk ref]
	} else {
	    set thunk3 {}
	}

	# Start building the thunk function

	set idx -1
	set block [$thunk block]

	$thunk setAsCurrentDebuggingScope
	$block build-in $b


	# Make code to declare parameters and handle variable args
	$b @location 1
	foreach paramName {clientData interp argc argv} {
	    set $paramName [$thunk param [incr idx] $paramName]
	}
	lassign [dict get $bytecode signature] restype argtypes
	set defaults [dict get $bytecode argumentDefaults]
	set argsIdx -1
	if {"args" eq [lindex $defaults end 0]} {
	    set argsIdx [llength $defaults]
	}

	my CheckArgcInRange $name $interp $argc $argv $defaults $argsIdx

	# Make code to set argument values and apply defaults for
	# varargs
	$b @location 2

	set realargs {}
	set idx 0
	foreach arginfo $defaults {
	    lassign $arginfo argName argDefaulted argDefault
	    incr idx
	    if {$argsIdx >= 0 && $idx >= $argsIdx} {
		set 0 [Const 0]
................................................................................
	    $b assume [$b gt [$b refCount $val] [Const 0]]
	    lappend realargs $val
	    if {[info exists argsToClear]} {
		break
	    }
	}

	# Make code to invoke the actual procedure

	$b @location 3
	set value [$b call [$func ref] $realargs "value"]
	SetTailCall $value 0
	if {$nre} {
	    $b NRAddCallback [$thunk2 ref] $value
	    $b launchCoroRunner $value
	}

	$b @location 4

	if {[info exists argsToClear]} {
	    my Tcl_DecrRefCount $argsToClear
	}
	if {$nre} {
	    $b ret [Const 0 int]
	    $b @loc {}
	    set block [$thunk2 block]
	    $thunk2 setAsCurrentDebuggingScope
	    $block build-in $b
	    $b @location 4
	    set data_ [$thunk2 param 0 "data"]
	    set interp_ [$thunk2 param 1 "interp"]
	    set result_ [$thunk2 param 2 "result"]
	    set handle [$b load [$b gep $data_ 0]]
	    set value [$b NRReturnToThunk $handle $returnType]
	    my MapResultToTcl $thunk2 $interp_ $value $returnType
	} else {
	    my MapResultToTcl $thunk $interp $value $returnType
	}
	$b @loc {}

	if {$nre} {
	    $thunk2 verify
	    $thunk3 verify
	}
	$thunk verify
	my InstallCommand $name $thunk $thunk3

	return $thunk
    }

    # ThunkBuilder:MakeObjCmdForNR --
    #
    #	Makes the 'objProc' for a command with an NRE implementation
    #
    # Parameters:
    #   b - Builder that is building LLVM-IR
    #	thunk - Wrapper function under construction
    #	nrProc - LLVM Tcl_ObjCmdProc reference for the NRE version to be wrapped
    #
    # Results:
    #	None.

    method MakeObjCmdForNR {b thunk nrProc} {
	set block [$thunk block]
	$thunk setAsCurrentDebuggingScope
	$block build-in $b
	$b @location 1
	set clientData [$thunk param 0 "clientData"]
	set interp [$thunk param 1 "interp"]
	set objc [$thunk param 2 "objc"]
	set objv [$thunk param 3 "objv"]
	my Tcl_NRCallObjProc $interp $nrProc $clientData $objc $objv
	$b ret [Const 0 int]
    }

    # ThunkBuilder:CheckArgcInRange --
    #
    #	Generate code to test whether the argument count to a command
    #	implementation matches that which is required for calling the
    #	function.
    #
................................................................................

    # ThunkBuilder:MapResultToTcl --
    #
    #	Generate code to create a Tcl value that represents the output of a
    #	function.
    #
    # Parameters:
    #	thunk -
    #		The thunk under cosntruction
    #	interp -
    #		The LLVM value reference to the Interp*.
    #	result -
    #		The LLVM value reference to the result of the wrapped
    #		function.
    #	resultType -
    #		The human-readable type descriptor for the result of the
................................................................................
    #		wrapped function. Note that this cannot be deduced from the
    #		value itself; some Tcl logical types may be convergently
    #		mapped at the LLVM level.
    #
    # Results:
    #	None.

    method MapResultToTcl {thunk interp result resultType} {

	# This only happens when all paths are failing paths
	if {$resultType in {"VOID FAIL" FAIL}} {
	    $b ret $result
	    return
	}
	if {[string match "FAIL *" $resultType]} {
	    # If a failure happened, the error message will have already been

Changes to demos/perftest/tester.tcl.

1264
1265
1266
1267
1268
1269
1270








1271
1272
1273
1274
1275
1276
1277
....
2193
2194
2195
2196
2197
2198
2199

2200
2201
2202
2203
2204
2205
2206
....
2353
2354
2355
2356
2357
2358
2359
2360
2361
2362
2363
2364
2365
2366
2367
....
2392
2393
2394
2395
2396
2397
2398

2399
2400
2401
2402
2403
2404
2405
2406
    }
    set lcm 1
    dict for {p c} $primes {
	set lcm [expr {$lcm * $p ** $c}]
    }
    return $lcm
}









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

................................................................................
    {cleanopt {expandtest::test12}}

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

    {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}
................................................................................
    calltest3
    # Callframe tests
    callframe::test1
    callframe::test2
    callframe::test3
    callframe::test4
    # The interprocedural tests
    mrtest::*
    coscaller1
    coscaller2
    xsum xsum2
    # Namespace tests
    nstestaux::pts
    nstest::nstest0
    nstest::nstest1
................................................................................
    expandtest::test10
    expandtest::test11
    expandtest::test12

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

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






>
>
>
>
>
>
>
>







 







>







 







|







 







>
|







1264
1265
1266
1267
1268
1269
1270
1271
1272
1273
1274
1275
1276
1277
1278
1279
1280
1281
1282
1283
1284
1285
....
2201
2202
2203
2204
2205
2206
2207
2208
2209
2210
2211
2212
2213
2214
2215
....
2362
2363
2364
2365
2366
2367
2368
2369
2370
2371
2372
2373
2374
2375
2376
....
2401
2402
2403
2404
2405
2406
2407
2408
2409
2410
2411
2412
2413
2414
2415
2416
    }
    set lcm 1
    dict for {p c} $primes {
	set lcm [expr {$lcm * $p ** $c}]
    }
    return $lcm
}

proc rectest1 {{n 3}} {
    if {$n == 0} {
	return {}
    } else {
	return .[rectest1 [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}]]

................................................................................
    {cleanopt {expandtest::test12}}

    {bug-0616bcf08e::msrange 0 10}
    {bug-0616bcf08e::msrange2 0 10}
    {singleton::lforeach}
    {singleton::llindex}
    {singleton::srange}
    {rectest1}
    {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}
................................................................................
    calltest3
    # Callframe tests
    callframe::test1
    callframe::test2
    callframe::test3
    callframe::test4
    # The interprocedural tests
    # mrtest::*			-- NO NRE
    coscaller1
    coscaller2
    xsum xsum2
    # Namespace tests
    nstestaux::pts
    nstest::nstest0
    nstest::nstest1
................................................................................
    expandtest::test10
    expandtest::test11
    expandtest::test12

    # Combined feature tests
    lcmRange
    bug-0616bcf08e::*
    # rectest1                  -- NO NRE
    # qsort  			-- NO NRE
    impure
    impure-caller
    impure-typecheck-int
    impure2
    comps
    bug-7c599d4029::*
    singleton::*