# tycon.tcl --
#
#	This provides certain key common services to the implementation,
#	notably type and constant manufacturing, but also the root class that
#	knows about things like how to make closures.
#
# Copyright (c) 2014-2017 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.
#
#------------------------------------------------------------------------------

namespace eval ::LLVM {
    # The actual flag values to use in the INT type
    variable INT.type.32bit 0
    variable INT.type.64bit 1

    # The actual flag values to use in the NUMERIC type
    variable NUMERIC.type.int 0
    variable NUMERIC.type.double 1

    # Named structure types need to be only created once
    variable NamedTypeCache {}
    variable NamedTypeCacheAhead {}

    # LLVM::Const --
    #
    #	Create a constant as an LLVM value reference. Note that this does not
    #	do anything to merge constants; that's a service provided directly by
    #	LLVM without our intervention.
    #
    # Parameters:
    #	value -	The value of the constant, which is a Tcl value.
    #	type (optional) -
    #		The type descriptor of the value. If the type is omitted, it
    #		is assumed to be an int32.
    #
    # Results:
    #	The LLVM value reference.

    proc Const {value {type int}} {
	switch -regexp -- $type {
	    "^INT$" {
		return [ConstInt [Type int] $value 0]
	    }
	    {^int\d*$} {
		return [ConstInt [Type $type] $value 0]
	    }
	    "^INT BOOLEAN$" - "^boolean$" {
		if {[string is true -strict $value]} {
		    return [ConstInt [Type int] 1 0]
		}
		if {[string is false -strict $value]} {
		    return [ConstInt [Type int] 0 0]
		}
		error "invalid boolean value \"$value\""
	    }
	    "^double$" - "^DOUBLE$" {
		return [ConstReal [Type double] $value]
	    }
	    "^bool$" - "^ZEROONE$" {
		if {[string is true -strict $value]} {
		    return [ConstInt [Type bool] 1 0]
		}
		if {[string is false -strict $value]} {
		    return [ConstInt [Type bool] 0 0]
		}
		error "invalid boolean value \"$value\""
	    }
	    "^STRING$" - "^EMPTY$" {
		variable thunkBuilder
		set theObj [$thunkBuilder obj.constant $value]
		return $theObj
	    }
	    default {
		error "constant type not handled: $type"
	    }
	}
    }

    # LLVM::Split --
    #
    #	Divide a string into pieces. Does not assume that separators are
    #	single characters. Handles not splitting braced sub-pieces.
    #
    # Parameters:
    #	string -
    #		The string to split up.
    #	separator (optional) -
    #		The string that separates the parts of the original string.
    #		The string may be a multi-character sequence.
    #
    # Results:
    #	A Tcl list of pieces.

    proc Split {string {separator ,}} {
	set acc ""
	set pieces {}
	set S \u0001
	foreach piece [split [string map [list $separator $S] $string] $S] {
	    append acc $piece
	    if {[regexp -all {\{} $acc] == [regexp -all {\}} $acc]} {
		lappend pieces $acc
		set acc ""
		continue
	    }
	    append acc $separator
	}
	if {$acc ne ""} {error "unbalanced string"}
	return $pieces
    }

    # LLVM::Type --
    #
    #	Create a type as an LLVM type reference.
    #
    # Parameters:
    #	descriptor -
    #		The description of the type.
    #
    # Results:
    #	The LLVM type reference.

    proc Type {descriptor} {
	variable TypeCache
	if {[info exist TypeCache($descriptor)]} {
	    return $TypeCache($descriptor)
	}
	set t [string trim [string map {\n " "} $descriptor]]
	try {
	switch -regexp -matchvar m -- $t {
	    {^void\s*\*$} - {^ClientData$} {
		# Special case: LLVM doesn't like pointer to void.
		return [Type char*]
	    }
	    ^mp_digit$ {
		# Defined in tcl.h
		return [Int32Type]
	    }
	    ^void$ {
		return [VoidType]
	    }
	    ^int$ {
		return [Int32Type]
	    }
	    ^long$ {
		# Machine word
		return [IntType [expr {$::tcl_platform(wordSize) * 8}]]
	    }
	    {^int(\d+)$} {
		return [IntType [lindex $m 1]]
	    }
	    ^STRING$ - ^EMPTY$ {
		return [Type named{Tcl_Obj}*]
	    }
	    ^ZEROONE$ - ^BOOLEAN$ - "^ZEROONE BOOLEAN$" {
		return [Type bool]
	    }
	    ^INT$ - ^ENTIER$ - "^INT BOOLEAN$" {
		return [Type named{INT,kind:int1,i32:int,i64:int64}]
	    }
	    ^NUMERIC$ {
		return [Type named{NUMERIC,kind:int1,int:INT,double:DOUBLE}]
	    }
	    ^FOREACH$ {
		return [Type named{FOREACH,val:int,max:int}]
	    }
	    ^DICTITER$ {
		return [Type "named{DICTFOR,
			search:DictSearch,
			dict:STRING,
			key:STRING,
			value:STRING,
			ref:int,
			done:int1}*"]
	    }
	    ^WIDE$ {
		return [Int64Type]
	    }
	    ^char$ - ^byte$ {
		return [Int8Type]
	    }
	    ^bool$ {
		return [Int1Type]
	    }
	    ^double$ - ^DOUBLE$ {
		return [DoubleType]
	    }
	    ^float$ - ^FLOAT$ {
		return [FloatType]
	    }
	    ^CALLFRAME$ {
		return [Type named{CallFrame}*]
	    }
	    ^CALLFRAME {
		set packaged [Type [lrange $t 1 end]]
		return [Type struct{[Type CALLFRAME],$packaged}]
	    }
	    {^VOID FAIL$} - {^VOID\?$} - {^FAIL$} - {^NEXIST$} -
	    {^NOTHING$} {
		return [Type bool]
	    }
	    {^(.*) FAIL$} - {^FAIL (.*)} - {^(.*)\?$} - {^NEXIST (.*)$} {
		return [Type struct{[Type bool],[Type [lindex $m 1]]}]
	    }
	    {^IMPURE (.*)} {
		return [Type struct{[Type STRING],[Type [lindex $m 1]]}]
	    }
	    {\*$} {
		return [PointerType [Type [string range $t 0 end-1]] 0]
	    }
	    {^LLVMTypeRef_} {
		# In case we get a real LLVM type reference in here
		return $t
	    }
	    {^struct\s*{(.*)}$} {
		set pieces [Split [lindex $m 1]]
		return [StructType [lmap p $pieces {Type $p}] 0]
	    }
	    {^named\s*{(.*)}$} {
		variable NamedTypeCache
		variable NamedFieldIndices
		variable NamedTypeCacheAhead
		set pieces [lassign [Split [lindex $m 1]] name]
		set name [string trim $name]
		if {[dict exists $NamedTypeCacheAhead $name]} {
		    set type [dict get $NamedTypeCacheAhead $name]
		    if {[llength $pieces] == 0} {
			return $type
		    }
		    dict unset NamedTypeCacheAhead $name
		} else {
		    if {[dict exists $NamedTypeCache $name]} {
			return [dict get $NamedTypeCache $name]
		    }
		    try {
			set index -1
			set type [NamedStructType $name [lmap p $pieces {
			    incr index
			    if {[regexp {^(\w+):(.+)$} [string trim $p] -> n t]} {
				dict set NamedFieldIndices($name) $n $index
				set p $t
			    }
			    Type $p
			}] 0]
			dict set NamedTypeCache $name $type
			return $type
		    } on error {} {
			set type [NamedStructType $name {} 0]
		    }
		}
		# Try the other way, see if this fixes self-reference issues
		set index -1
		dict set NamedTypeCache $name $type
		StructSetBody $type [lmap p $pieces {
		    incr index
		    if {[regexp {^(\w+):(.+)$} [string trim $p] -> n t]} {
			dict set NamedFieldIndices($name) $n $index
			set p $t
		    }
		    Type $p
		}] 0
		return $type
	    }
	    {^array\s*{(.*)}$} {
		set pieces [Split [lindex $m 1]]
		if {[llength $pieces] != 2} {
		    error "wrong args to array: [join $pieces ,]"
		}
		lassign $pieces type count
		return [ArrayType [Type $type] $count]
	    }
	    {^func\s*{(.*)}$} {
		set pieces [Split [lindex $m 1] <-]
		if {[llength $pieces] != 2} {
		    error "wrong args to func: [join $pieces <-]"
		}
		lassign $pieces ret args
		set pieces [Split $args]
		set va [expr {[string trim [lindex $pieces end]] eq "..."}]
		if {$va} {
		    set pieces [lrange $pieces 0 end-1]
		}
		return [FunctionType [Type $ret] [lmap p $pieces {Type $p}] $va]
	    }
	    default {
		variable NamedTypeCache
		if {[dict exists $NamedTypeCache $t]} {
		    return [dict get $NamedTypeCache $t]
		}
		variable NamedTypeCacheAhead
		if {[dict exists $NamedTypeCacheAhead $t]} {
		    return [dict get $NamedTypeCacheAhead $t]
		}
		error "FIXME: unsupported type \"$descriptor\" ($t)"
	    }
	}
	} on return typeInstance {
	    set TypeCache($descriptor) $typeInstance
	    return $typeInstance
	}
    }

    # LLVM::FieldIndex --
    #
    #	Get the index into a named structure for a particular named field.
    #
    # Parameters:
    #	structName -
    #		The name of the structure that contains the field.
    #	fieldName -
    #		The name of the field in the structure.
    #
    # Results:
    #	The index into the field.

    proc FieldIndex {structName fieldName} {
	variable NamedFieldIndices
	if {![info exists NamedFieldIndices($structName)]} {
	    return -code error "no structure called \"$structName\""
	}
	set defs $NamedFieldIndices($structName)
	if {![dict exists $defs $fieldName]} {
	    return -code error \
		"no field called \"$fieldName\" in \"$structName\""
	}
	return [dict get $defs $fieldName]
    }

    # LLVM::timeit --
    #
    #	Reporting wrapper round [time]. This only reports the execution time
    #	if the configuration settings are such that reports are desired.
    #
    # Parameters:
    #	phase -	Short (one or two word) description of what the timed script
    #		is doing.
    #	script -
    #		The script to run that is being instrumented.
    #
    # Results:
    #	None.

    proc timeit {phase script} {
	variable time
	set t [time {set c [catch {uplevel 1 $script} a b]}]
	if {$c} {
	    set ei [split [dict get $b -errorinfo] \n]
	    set ei [lreplace $ei end-2 end \
		[regsub {"uplevel" body} [lindex $ei end-2] \
			"timed script for phase '$phase'"]]
	    dict set b -errorinfo [join $ei \n]
	    dict set b -level 1
	    dict set b -code 1
	    return -options $b $a
	}
	if {$time > 0} {
	    puts "${phase}: [lrange $t 0 1]"
	}
    }

    # LLVM::DBTY --
    #
    #	Helper procedure for creating debugging metadata delegates for
    #	types. Only intended to be used from inside methods of the Module
    #	class.
    #
    # Parameters:
    #	var -	Variable in which to write the metadata handle.
    #	type -	The LLVM type that we are creating metadata for.
    #	dbtype -
    #		The general class of debugging type, "pointer", "struct", etc.
    #		Used to select which metadata constructor to use.
    #	args... -
    #		Arguments to pass onto the metadata constrcutor
    #
    # Results:
    #	None.

    proc DBTY {var <- type dbtype args} {
	set module [uplevel 1 self]
	upvar 1 $var v dbty dbty

	# Set the source location
	set finfo [info frame -1]
	set file [$module debug file]
	$module debug file [dict get $finfo file]
	set line [$module debug line]
	$module debug line [dict get $finfo line]

	try {
	    if {$type ne ""} {
		set t [uplevel 1 [list Type $type]]
	    }
	    set con ${dbtype}Type
	    if {$dbtype eq "pointer" && [lindex $args 0] eq ""} {
		lset args 0 $type
	    }
	    set v [uplevel 1 [list $module debug $con {*}$args]]
	    if {$type ne "" && ![info exists dbty($t)]} {
		set dbty($t) $v
	    }
	} on error msg {
	    uplevel 1 [list $module Warn "failed to build type $type: $msg"]
	} finally {
	    $module debug file $file
	    $module debug line $line
	}
	return
    }

    # LLVM::struct --
    #
    #	Helper procedure for creating struct types and their debugging
    #	metadata delegates. Only intended to be used from inside methods of
    #	the Module class.
    #
    # Parameters:
    #	name -	Name of the structure type that will be created. Also the name
    #		of the local variable in the caller that will have the
    #		metadata handle assigned to it. If the empty string, an
    #		unnamed structure will be created; unnamed structures use
    #		structural equality.
    #	elements (optional) -
    #		Tcl list of elements of the structure. Each of these must be
    #		the type of the element, and may be preceded by the name of
    #		the element and a colon *provided* the struct has a name. If
    #		omitted, this is intended to be an opaque structure that can
    #		only be used by reference.
    #
    # Results:
    #	None.

    proc struct {name {elements {}}} {
	set module [uplevel 1 self]
	upvar 1 $name v dbty dbty ptr ptr

	# Build the LLVM structure type
	set head [expr {$name eq "" ? "struct\{" : "named\{$name,"}]
	if {[llength $elements]} {
	    set elements [uplevel 1 [list subst $elements]]
	    set t [Type "${head}[join $elements ,]\}"]
	} elseif {$name ne ""} {
	    # Opaque structure type that only Tcl's implementation knows all
	    # the secrets of.
	    set t [Type "named\{$name\}"]
	} else {
	    # Because we need something...
	    set t [Type "struct{int}"]
	}

	# Set the source location
	set finfo [info frame -1]
	set file [$module debug file]
	$module debug file [dict get $finfo file]
	set line [$module debug line]
	$module debug line [dict get $finfo line]

	# Build the LLVM debugging type, using best guesses at the inner types
	# by doing dereference decomposition.
	try {
	    set args [list $name]
	    foreach elem $elements {
		set elem [Type [regsub {^[^:]+:} $elem ""]]
		if {[info exist dbty($elem)]} {
		    lappend args $dbty($elem)
		    continue
		}
		set usetype $ptr
		set derefs {}

		while true {
		    switch [GetTypeKind $elem] {
			"LLVMPointerTypeKind" {
			    lappend derefs pointerType
			}
			"LLVMArrayTypeKind" {
			    lappend derefs \
				[list arrayType [GetArrayLength $elem]]
			}
			default break
		    }
		    set elem [GetElementType $elem]
		}

		if {[info exist dbty($elem)]} {
		    set elem $dbty($elem)
		    foreach composer [lreverse $derefs] {
			set elem [$module debug {*}[linsert $composer 1 "" $elem]]
		    }
		    lappend args $elem
		} else {
		    # Can't really figure this out, so use a pointer
		    lappend args $ptr
		}
	    }

	    set v [$module debug structType {*}$args]
	    set dbty($t) $v
	    return $v
	} on error msg {
	    uplevel 1 [list $module Warn "failed to build type $type: $msg"]
	} finally {
	    $module debug file $file
	    $module debug line $line
	}
    }

    # LLVM::simultaneousDeclare --
    #
    #	Helper procedure for LLVM::struct, allowing the structures created
    #	within its body to be treated as if they are simultaneously declared,
    #	i.e., for them all to cross-reference each other without much regard
    #	for order of declaration. Note that only forward declaration of
    #	*pointers* to other structures is actually properly supported, as the
    #	size of each structure is required at the time of it actually being
    #	declared.
    #
    # Parameters:
    #	script -
    #		The code containing the collection of declarations that will
    #		be permitted to cross-reference each other. NB: Forward
    #		declarations are picked up by simple regular expression
    #		parsing; only [struct] calls that are the first on their line
    #		will be actually handled for forward declaration.
    #
    # Results:
    #	None.

    proc simultaneousDeclare {script} {
	variable NamedTypeCacheAhead
	set RE {^\s*struct\s+(\w+)}
	foreach {- name} [regexp -all -inline -line $RE $script] {
	    dict set NamedTypeCacheAhead $name [NamedStructType $name {} 0]
	}
	tailcall try $script finally {
	    apply {{} {
		variable NamedTypeCache
		variable NamedTypeCacheAhead
		set NamedTypeCache \
		    [dict merge $NamedTypeCache $NamedTypeCacheAhead]
		set NamedTypeCacheAhead {}
	    } ::LLVM}
	}
    }

    # Class LLVM::llvmEntity --
    #
    #	Support/root class for classes in the Tcl to LLVM system, providing
    #	selected common services, allowing direct access to parts of the API
    #	such as the llvmtcl package and the constant and type factories.
    #
    # Construction Parameters:
    #	None.
    #
    # Public properties:
    #	None.

    oo::class create llvmEntity {
	constructor {} {
	    namespace path [list {*}[namespace path] ::llvmtcl ::LLVM]
	    #oo::objdefine [self] filter LOG
	}

	# llvmEntity:LOG --
	#
	#	Logging filter that allows detailed tracking of what calls
	#	have been made to a particular class. Not applied by default.
	#
	# Parameters:
	#	N/A (depends on what the filter is wrapping in this call)
	#
	# Results:
	#	N/A (depends on what the wrapped method returns)

	method LOG args {
	    set what [concat "[self] [lindex [self target] 1]" $args]
	    puts stderr ">>$what>>"
	    try {
		return [set v [next {*}$args]]
	    } finally {
		if {[info exists v]} {
		    puts stderr "<<$what<<$v"
		}
	    }
	}

	# llvmEntity:Warn --
	#
	#	How to print a warning message to standard error.
	#
	# Parameters:
	#	msg -	The format string to use to produce the message.
	#	args... -
	#		The arguments to pass into the formatting engine.
	#
	# Results:
	#	None.

	method Warn {msg args} {
	    set where [info frame -1]
	    set l [dict get $where line]
	    if {[dict exists $where file]} {
		set f [file tail [dict get $where file]]
	    } elseif {[dict exists $where lambda] && [
		set theline [lindex [split [dict get $where lambda] "\n"] $l]
		string first "@location" $theline
	    ] >= 0} {
		regexp {@location (\d+) ([^\s;]*)} $theline -> l f
		set f [file tail $f]
	    } else {
		try {
		    set c [self caller]
		    set f [regsub .*:: [lindex $c 0] {}].[lindex $c end]
		} on error {} {
		    set f [lindex [info level -1] 0]
		}
	    }
	    puts stderr [format "WARNING:${f}:${l}:$msg" {*}$args]
	}

	# llvmEntity:GenerateFunctionName --
	#
	#	Generate the actual LLVM name of a Tcl command.
	#
	# Parameters:
	#	fqcmd -
	#		The fully-qualified Tcl command name.
	#	by -	One of 'types', 'typecodes' or 'arguments' to indicate
	#		what the $vals argument to this method is.
	#	vals -	A list of codegen type names if $by is 'types', a list
	#		of tclquadcode numeric typecodes if $by is
	#		'typecodes', or a list of tclquadcode values if $by is
	#		'arguments'.
	#
	# Results:
	#	The actual LLVM function name as an ordinary Tcl string.

	method GenerateFunctionName {fqcmd by vals} {
	    switch -- $by {
		"types" {
		    set vals [lmap tyname $vals {
			upvar 0 ::quadcode::dataType::$tyname tycode
			set tycode
		    }]
		}
		"typecodes" {
		    foreach code $vals {
			# Verify that we've really got an integer
			incr code 0
		    }
		}
		"arguments" {
		    my variable vtypes
		    set vals [lmap s $vals {
			typeOfOperand $vtypes $s
		    }]
		}
		default {
		    return -code error "unknown 'by': $by"
		}
	    }
	    return [list tcl $fqcmd $vals]
	}

	# llvmEntity:closure --
	#
	#	Creates a method in the current object that will run the given
	#	script in its "current context", with the currently visible
	#	variables available with their current values. It takes
	#	copies, so it does not support sharing state that way (use an
	#	instance variable if that is desired).
	#
	#	Note that operations like [next] and [self] are not available.
	#
	# Parameters:
	#	name -	The name of the method to create.
	#	arguments -
	#		The formal arguments to the method. These should NOT
	#		be the same as any variables visible in the calling
	#		context.
	#	body -	The script that implements the method.
	#
	# Results:
	#	N/A (depends on what the wrapped method returns)

	method closure {name arguments body} {
	    set vars [lmap v [uplevel 1 info vars] {
		if {[uplevel 1 [list info exist $v]]
		    && ![uplevel 1 [list array exists $v]]} {set v} continue}]
	    oo::objdefine [self] forward $name apply [list \
		[list {*}$vars {*}$arguments] $body \
			[uplevel 1 namespace current]] \
		{*}[lmap v $vars {uplevel 1 [list set $v]}]
	}

	unexport closure
    }
}

# Local Variables:
# mode: tcl
# fill-column: 78
# auto-fill-function: nil
# buffer-file-coding-system: utf-8-unix
# End:
