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

		}
		"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.
    #

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

    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

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 0 [set OK [Const 0]]
	set 1 [set ERROR [Const 1]]
	set makingThunks 0
	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

    }
    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::*