# thunk.tcl --
#
#	Constructs the interface between the code generated by the compilation
#	engine and Tcl. Manages the generation of a function that creates Tcl
#	commands for each of the functions we compile. See tclapi.tcl for the
#	part of this class that maps Tcl's own API into LLVM.
#
# Copyright (c) 2015 by Donal K. Fellows
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
#------------------------------------------------------------------------------

# Class ThunkBuilder --
#
#	This class constructs the interface between Tcl and the rest of the
#	LLVM-generated code.
#
# Construction Parameters:
#	module -
#		The module that owns this interface.
#
# Public properties:
#	None.

oo::class create ThunkBuilder {
    superclass BuildSupport
    variable m b metathunk metathunkblock metathunkerror metathunkref
    variable makingThunks thunkprocmeta
    variable 0 1 OK ERROR
    variable Tcl_Interp Tcl_UniChar Tcl_Obj Tcl_ObjType mp_int Tcl_RegExp
    variable 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 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,Tcl_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<-Tcl_Interp*}]
	my buildInSection preface {
	    [$metathunk block "enter"] build-in $b
	    my variable interp
	    set interp [$metathunk param 0 "interp"]
	}

	# ThunkBuilder:fprintf,fflush,printf,exit,stdout,stderr --
	#
	#	Various bits and pieces from the C standard library.
	#
	# Parameters:
	#	Various, see C standard library documentation.
	#
	# Results:
	#	Various, see C standard library documentation.

	my Global fprintf func{int<-void*,char*,...}
	my Global fflush func{int<-void*}
	my Global printf func{int<-char*,...}
	my Global exit func{void<-int}
	# Note that these three are bound specially during the loading process
	my Global stdin void*
	my Global stdout void*
	my Global stderr void*

	my InitTclAPI $interp

	$b @apiFunctions $module [self]

	my buildInSection initConstant {
	    set metathunkblock [$metathunk block createConstants]
	    $b br $metathunkblock
	    set metathunkerror [$metathunk block error]
	    $metathunkblock build $b {
		foreach {var str len} ${obj.constants.pending} {
		    $b Call ${tcl.obj.constant} $var $str $len
		}
	    }
	}
    }

    method buildInSection {id script} {
	set line [dict get {
	    preface 1
	    API 2 APIvar 3
	    initConstant 4 commands 5
	    packageProvide 6
	} $id]
	$m debug scope "" {
	    $metathunk setAsCurrentDebuggingScope
	    $b @location $line
	    uplevel 1 $script
	}
    }

    # ThunkBuilder:Print --
    #
    #	Write a message to an output stdio channel. More flexible than the
    #	'writeline' method.
    #
    # Parameters:
    #	msg -	The value to write.
    #	destination (optional) -
    #		Where to write to. Defaults to stdout but can be usefully
    #		overridden to "stderr".
    #	format (optional) -
    #		The format to use when writing. Defaults to %s\n, which
    #		behaves the same as the 'writeline' method.
    #
    # Results:
    #	None.

    method Print {msg {destination stdout} {format "%s\n"}} {
	set FILE [my $destination]
	set str [$b constString $msg "msg"]
	my fprintf $FILE [$b constString $format "format"] $str
	my fflush $FILE
	return
    }

    # ThunkBuilder:InstallCommand --
    #
    #	Generate the code to create a Tcl command for a compiled function.
    #
    # 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
	}
	return
    }

    # ThunkBuilder:finalize --
    #
    #	Finish the code building done by the thunk engine. The 'install'
    #	method SHOULD NOT be called until after this method has been called;
    #	this method is responsible for ensuring that the initialization
    #	function has actually been finished and put in a callable state. The
    #	LLVM optimizer should also not be used on a module with an unfinalized
    #	initialization function in it.
    #
    # Parameters:
    #	None.
    #
    # Results:
    #	None.

    method finalize {} {
	if {[info exist metathunkref]} {
	    return -code error "the API has already been finalized"
	}
	my variable interp
	my buildInSection packageProvide {
	    set block [$metathunk block leave]
	    $metathunkblock build $b {
		$b br $block
	    }
	    $block build $b {
		$b ret [my Tcl_PkgProvideEx $interp \
			[$b constString [$m name] "pkg.name"] \
			[$b constString "0.0.0.1" "pkg.version"] \
			[$b null void*]]
	    }
	    $metathunkerror build $b {
		$b ret $ERROR
	    }
	}
	$metathunk verify
	set metathunkref [$metathunk ref]
	$b destroy
	return
    }

    # ThunkBuilder:install --
    #
    #	Run the module's initialization function using the execution engine
    #	configured into the module.
    #
    # Parameters:
    #	None.
    #
    # Results:
    #	None.

    method install {} {
	if {![info exist metathunkref]} {
	    return -code error \
		"the API must be finalized before being installed"
	}
	CallInitialisePackageFunction [$m engine] $metathunkref
    }

    # ThunkBuilder:Global --
    #
    #	Bind a global variable or function to a method of this class and
    #	return the value of the global. Variables get bound to a method that
    #	reads them. Functions get bound to a method that calls them.
    #
    # Parameters:
    #	name -	The name of the global.
    #	type -	The type of the global (an LLVM type reference). Note that the
    #		kind of type (i.e., function or not) fundamentally alters what
    #		this method does in the binding code.
    #
    # Results:
    #	The LLVM value reference to the global.

    method Global {name type} {
	set n $name
	set type [Type $type]
	if {[GetTypeKind $type] eq "LLVMFunctionTypeKind"} {
	    set g [$m function.extern $n $type]
	    set c [CountParamTypes $type]
	    set v [IsFunctionVarArg $type]
	    my closure $name args {
		# Because these are *much* less nasty than crashes!
		if {$v && [llength $args] < $c} {
		    return -code error "insufficient arguments"
		} elseif {!$v && [llength $args] != $c} {
		    return -code error "wrong number of arguments"
		}
		for {set i 0} {$i < $c} {incr i} {
		    set expected [TypeOf [GetParam $g $i]]
		    set got [TypeOf [lindex $args $i]]
		    if {$got ne $expected} {
			return -code error "type mismatch at argument ${i}:\
				expected [PrintTypeToString $expected] but\
				got [PrintTypeToString $got]"
		    }
		}
		$b call $g $args
	    }
	} else {
	    set g [$m global.get $n $type]
	    my closure $name {} {
		$b load $g
	    }
	}
	return $g
    }

    # ThunkBuilder:thunk --
    #
    #	Generate the Tcl binding thunk function for a function generated by
    #	the code generator.
    #
    # 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 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]

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

	$b @location 2

	set realargs {}
	set idx 0
	foreach arginfo $defaults {
	    lassign $arginfo argName argDefaulted argDefault
	    set index [Const [incr idx]]

	    if {$argDefaulted} {
		set defval [my obj.constant $argDefault]
		set val [$b call ${thunk.arg.default} \
			[list $index $argc $argv $defval]]
	    } else {
		set val [$b dereference $argv $idx]
	    }
	    SetValueName $val $argName
	    $b assume [$b gt [$b refCount $val] [Const 0]]
	    lappend realargs $val
	}

	$b @location 3

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

	$b @location 4

	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.
    #
    # Parameters:
    #	name -	The (fully-qualified) name of the generated function and the
    #		command that this function will represent.
    #	interp -
    #		The LLVM value reference to the Tcl_Interp*.
    #	argc -	The LLVM value reference to the actual argument count.
    #	argv -	The LLVM value reference to the actual array of arguments.
    #	argDefaults -
    #		The description of what default arguments are expected. A Tcl
    #		list of descriptors for each argument.
    #
    # Results:
    #	None.

    method CheckArgcInRange {name interp argc argv argDefaults} {
	upvar 1 thunk thunk
	# Compute how many arguments we expect, including 1 for cmd name
	set minargc [set maxargc 1]
	foreach argInfo $argDefaults {
	    incr maxargc
	    incr minargc [expr {[lindex $argInfo 1] == 0}]
	}

	# Test if we've got the right number of arguments
	set newblock [$thunk block]
	set wrongargs [$thunk block "wrongNumArgs"]
	$b condBr [$b lt $argc [Const $minargc]] \
	    $wrongargs $newblock
	$newblock build $b {
	    set newblock [$thunk block]
	    $b condBr [$b gt $argc [Const $maxargc]] \
		$wrongargs $newblock
	}

	# Too few or too many arguments.
	# Generate the "wrong # args" message and return TCL_ERROR
	$wrongargs build $b {
	    set argnamelist {}
	    set argnames [$b constString [lmap argInfo $argDefaults {
		lassign $argInfo argName argDefaulted
		lappend argnamelist $argName
		set mark [expr {$argDefaulted ? "?" : ""}]
		string cat $mark $argName $mark
	    }] wrongargs_[join $argnamelist _]]
	    my Tcl_WrongNumArgs $interp $1 $argv $argnames
	    $b ret $ERROR
	}

	# Ready things for the next thing in the main instruction stream
	$newblock build-in $b
	return
    }

    # ThunkBuilder:MapResultToTcl --
    #
    #	Generate code to create a Tcl value that represents the output of a
    #	function.
    #
    # Parameters:
    #	interp -
    #		The LLVM value reference to the Tcl_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 $ERROR
	    return
	}
	set isFailType 0
	if {[string match "* FAIL" $resultType]} {
	    set isFailType 1
	    set resultType [string range $resultType 0 end-5]
	} elseif {[string match "FAIL *" $resultType]} {
	    set isFailType 1
	    set resultType [string range $resultType 5 end]
	}
	if {$isFailType} {
	    # If a failure happened, the error message will have already been
	    # set by the opcode that generated it.
	    set isFail [$thunk block]
	    set next [$thunk block]
	    $b condBr [$b maybe $result] $isFail $next
	    $isFail build $b {
		$b ret $ERROR
	    }
	    $next build-in $b
	    set result [$b unmaybe $result]
	}
	if {[regexp "^IMPURE (.*)" $resultType]} {
	    set result [$b impure.string $result]
	    SetValueName $result @result
	    set resultType STRING
	}
	upvar 0 thunk.result.$resultType thunkResultMapper
	if {![info exist thunkResultMapper]} {
	    error "unhandled result type: $resultType"
	}
	$b call $thunkResultMapper [list $interp $result]
	if {[info exists ::env(TQC_PRINT_REFERENCE_MANAGEMENT)]} {
	    $b printref [my Tcl_GetObjResult $interp] "result:"
	}
	$b ret $OK
	return
    }

    method buildProcedureMetadata {cmd bytecode storage} {
	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 proc [my cknew Proc "procmeta"]
	    $b storeInStruct $proc Proc.iPtr [$b cast(ptr) $interp void]
	    $b storeInStruct $proc Proc.refCount [Const 1]
	    $b storeInStruct $proc Proc.bodyPtr [$b null STRING];     # FIXME
	    $b storeInStruct $proc Proc.numArgs [Const 0];	      # FIXME
	    $b storeInStruct $proc Proc.numCompiledLocals [Const 0];  # FIXME
	    set ncl [$b null CompiledLocal*]
	    $b storeInStruct $proc Proc.firstLocalPtr $ncl;	      # FIXME
	    $b storeInStruct $proc Proc.lastLocalPtr $ncl;	      # FIXME
	    my Warn "Procedure metadata for $cmd not complete";	      # FIXME
	    $b store $proc $storage
	    dict set thunkprocmeta $cmd $proc
	}
    }
}

# Local Variables:
# mode: tcl
# fill-column: 78
# auto-fill-function: nil
# buffer-file-coding-system: utf-8-unix
# End:
