# macros.tcl --
#
#	Replicates key macros that define how Tcl's own API maps into LLVM.
#	Adjunct to tclapi.tcl and thunk.tcl.
#
# Copyright (c) 2015-2016 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.
#
#-----------------------------------------------------------------------------

oo::define ThunkBuilder {
    # ------------------------------------------------------------------
    #
    # ThunkBuilder:Tcl_IncrRefCount --
    #
    #	Increment the reference count of a Tcl_Obj. This follows the standard
    #	semantics for such values.
    #
    # Parameters:
    #	objPtr -
    #		The LLVM value reference to the Tcl_Obj*.
    #
    # Results:
    #	None.

    method @macros.Tcl_IncrRefCount {{inline {}}} {
	set f [$m local Tcl_IncrRefCount void<-Tcl_Obj* {*}$inline]
	my closure Tcl_IncrRefCount objPtr {
	    $b Call $Tcl_IncrRefCount $objPtr
	    return
	}

	params objPtr
	build {
	    nonnull $objPtr
	    set refCount [$b getelementptr $objPtr [list $0 $0] "refCount"]
	    $b store [$b addNoWrap [$b load $refCount] $1] $refCount
	    $b ret
	}

	oo::objdefine [self] export Tcl_IncrRefCount
    }

    # ------------------------------------------------------------------
    #
    # ThunkBuilder:Tcl_DecrRefCount --
    #
    #	Decrement the reference count of a Tcl_Obj, and delete it (with
    #	TclFreeObj) if this drops the count below 1. This follows the standard
    #	semantics for such values.
    #
    # Parameters:
    #	objPtr -
    #		The LLVM value reference to the Tcl_Obj*.
    #
    # Results:
    #	None.

    method @macros.Tcl_DecrRefCount {{inline {}}} {
	set f [$m local Tcl_DecrRefCount void<-Tcl_Obj* {*}$inline]
	my closure Tcl_DecrRefCount objPtr {
	    $b Call $Tcl_DecrRefCount $objPtr
	    return
	}

	params objPtr
	build {
	    nonnull $objPtr
	    set refCount [$b getelementptr $objPtr [list $0 $0] "refCount"]
	    set val [$b subNoWrap [$b load $refCount] $1]
	    $b condBr [$b le $val $0] $freeblock $nextblock
	label freeblock "freeObject"
	    my TclFreeObj $objPtr
	    my AssertDeallocated $objPtr
	    $b ret
	label nextblock "leave"
	    $b store $val $refCount
	    $b ret
	}

	oo::objdefine [self] export Tcl_DecrRefCount
    }

    # ------------------------------------------------------------------
    #
    # ThunkBuilder:TclFreeIntRep --
    #
    #	Remove the internal representation of a Tcl_Obj.
    #
    # Parameters:
    #	objPtr -
    #		The LLVM value reference to the Tcl_Obj*.
    #
    # Results:
    #	None.

    method @macros.TclFreeIntRep {{inline {}}} {
	set f [$m local TclFreeIntRep void<-Tcl_Obj* {*}$inline]
	my closure TclFreeIntRep objPtr {
	    $b Call $TclFreeIntRep $objPtr
	    return
	}

	params objPtr
	build {
	    nonnull $objPtr
	    set typeField [$b gep $objPtr 0 Tcl_Obj.typePtr]
	    set typePtr [$b load $typeField "typePtr"]
	    $b condBr [$b nonnull $typePtr] $check $done 
	label check:
	    set freeIntRepProc [$b dereference $typePtr 0 \
		    Tcl_ObjType.freeIntRepProc]
	    $b condBr [$b nonnull $freeIntRepProc] $free $clear
	label free:
	    set freeIntRep [$b cast(ptr) $freeIntRepProc \
		    func{void<-Tcl_Obj*} "freeIntRep"]
	    $b Call $freeIntRep $objPtr
	    $b br $clear
	label clear:
	    $b store [$b null Tcl_ObjType*] $typeField
	    $b br $done
	label done:
	    $b ret
	}

	oo::objdefine [self] export TclFreeIntRep
    }

    # ------------------------------------------------------------------
    #
    # ThunkBuilder:TclInvalidateStringRep --
    #
    #	Remove the string representation of a Tcl_Obj.
    #
    # Parameters:
    #	objPtr -
    #		The LLVM value reference to the Tcl_Obj*.
    #
    # Results:
    #	None.

    method @macros.TclInvalidateStringRep {{inline {}}} {
	set f [$m local TclInvalidateStringRep void<-Tcl_Obj* {*}$inline]
	my closure TclInvalidateStringRep objPtr {
	    $b Call $TclInvalidateStringRep $objPtr
	    return
	}

	params objPtr
	build {
	    nonnull $objPtr
	    set bytesField [$b gep $objPtr 0 Tcl_Obj.bytes]
	    set bytes [$b load $bytesField "bytes"]
	    $b condBr [$b nonnull $bytes] $actblock $doneblock
	label actblock "act"
	    $b condBr [$b neq $bytes [my tclEmptyStringRep]] \
		$freeblock $clearblock
	label freeblock "free"
	    set bytes [$b cast(ptr) $bytes void]
	    my Tcl_Free $bytes
	    if {![info exist ::env(NOASSERTS)]} {
		$b Call [$m intrinsic lifetime.end] [Const -1 int64] $bytes
	    }
	    $b br $clearblock
	label clearblock "clear"
	    $b store [$b null char*] $bytesField
	    $b br $doneblock
	label doneblock "done"
	    $b ret
	}

	oo::objdefine [self] export TclInvalidateStringRep
    }

    # ------------------------------------------------------------------
    #
    # ThunkBuilder:Tcl_GetHashValue --
    #
    #	Get the value from a hash entry.
    #
    # Parameters:
    #	hashEntryPtr -
    #		The LLVM value reference to the Tcl_HashEntry*.
    #	type (optional) -
    #		The desired type of the result, to which the value will be
    #		cast. If omitted, the default (void*) will be used.
    #
    # Results:
    #	The hash value in the hash entry.
    #
    # ------------------------------------------------------------------
    #
    # ThunkBuilder:Tcl_SetHashValue --
    #
    #	Set the value in a hash entry.
    #
    # Parameters:
    #	hashEntryPtr -
    #		The LLVM value reference to the Tcl_HashEntry*.
    #	value -	The value to be set in the hash entry.
    #
    # Results:
    #	None.
    #
    # ------------------------------------------------------------------
    #
    # ThunkBuilder:TclCreateHashEntry --
    #
    #	Create the entry for a hash key.
    #
    # Parameters:
    #	hashTablePtr -
    #		The LLVM value reference to the Tcl_HashTable*.
    #	key -	The key to be looked up in the hash table.
    #	isNew (optional) -
    #		Where to store the flag as to whether the entry is new or not.
    #
    # Results:
    #	The LLVM value reference to the Tcl_HashEntry*.
    #
    # ------------------------------------------------------------------
    #
    # ThunkBuilder:TclFindHashEntry --
    #
    #	Get the entry for a hash key.
    #
    # Parameters:
    #	hashTablePtr -
    #		The LLVM value reference to the Tcl_HashTable*.
    #	key -	The key to be looked up in the hash table.
    #
    # Results:
    #	The LLVM value reference to the Tcl_HashEntry*.

    method @macros.TclHashTable {} {
	my closure Tcl_GetHashValue {hashEntryPtr {type ""}} {
	    set value [$b dereference $hashEntryPtr 0 Tcl_HashEntry.clientData]
	    if {$type ne ""} {
		set type [Type $type]
		switch [GetTypeKind $type] {
		    "LLVMPointerTypeKind" {
			set value [$b castPtr2Ptr $value $type]
		    }
		    "LLVMIntegerTypeKind" {
			set value [$b castPtr2Int $value $type]
		    }
		    default {
			return -code error \
			    "can only store pointers and integers safely"
		    }
		}
	    }
	    return $value
	}

	my closure Tcl_SetHashValue {hashEntryPtr value} {
	    switch [GetTypeKind [TypeOf $value]] {
		"LLVMPointerTypeKind" {
		    set value [$b castPtr2Ptr $value [Type void*]]
		}
		"LLVMIntegerTypeKind" {
		    set value [$b castInt2Ptr $value [Type void*]]
		}
		default {
		    return -code error \
			"can only store pointers and integers safely"
		}
	    }
	    $b store $value [$b gep $hashEntryPtr 0 Tcl_HashEntry.clientData]
	    return
	}

	my closure TclFindHashEntry {hashTablePtr key} {
	    switch [GetTypeKind [TypeOf $key]] {
		"LLVMPointerTypeKind" {
		    set key [$b castPtr2Ptr $key [Type void*] "key"]
		}
		"LLVMIntegerTypeKind" {
		    set key [$b castInt2Ptr $key [Type void*] "key"]
		}
		default {
		    return -code error \
			"only support pointers and integers as keys"
		}
	    }
	    return [my Tcl_FindHashEntry $hashTablePtr $key]
	}

	my closure TclCreateHashEntry {hashTablePtr key {isNew ""}} {
	    switch [GetTypeKind [TypeOf $key]] {
		"LLVMPointerTypeKind" {
		    set key [$b castPtr2Ptr $key [Type void*] "key"]
		}
		"LLVMIntegerTypeKind" {
		    set key [$b castInt2Ptr $key [Type void*] "key"]
		}
		default {
		    return -code error \
			"only support pointers and integers as keys"
		}
	    }
	    if {$isNew eq ""} {
		set isNew [$b alloc int "isNew"]
	    }
	    return [my Tcl_CreateHashEntry $hashTablePtr $key $isNew]
	}

	oo::objdefine [self] export Tcl_GetHashValue Tcl_SetHashValue \
	    TclFindHashEntry TclCreateHashEntry
    }

    # ------------------------------------------------------------------
    #
    # ThunkBuilder:ckalloc --
    #
    #	Allocate memory using Tcl's memory manager.
    #
    # Parameters:
    #	size -	The size of the piece of memory. May be either a Tcl value or
    #		an LLVM value reference.
    #	type (optional) -
    #		The type description (human-readable) of the result. If
    #		omitted, the result will be a void* (strictly, an LLVM i8*).
    #
    # Results:
    #	LLVM value reference to pointer to the allocated memory.
    #
    # ------------------------------------------------------------------
    #
    # ThunkBuilder:cknew --
    #
    #	Allocate a structure using Tcl's memory manager.
    #
    # Parameters:
    #	type -	The type description (may be human-readable) of the thing that
    #		the result will point to.
    #	name (optional) -
    #		A name to give to the result value.
    #
    # Results:
    #	LLVM value reference to pointer to the allocated memory.

    method @macros.ckalloc {size_t} {
	my closure ckalloc {size {type ""} {name "ptr"}} {
	    if {[string is integer -strict $size]} {
		set size [Const $size $size_t]
	    }
	    if {[::tcl::pkgconfig get debug]} {
		set frameinfo [info frame -1]
		set file "/dev/null"
		if {[dict exists $frameinfo file]} {
		    set file [dict get $frameinfo file]
		}
		set file [$b constString $file "source.filename"]
		set line [Const [dict get $frameinfo line]]
		set block [my Tcl_DbCkalloc $size $file $line]
	    } else {
		set block [my Tcl_Alloc $size]
	    }
	    SetValueName $block $name
	    if {![info exist ::env(NOASSERTS)]} {
		$b Call [$m intrinsic lifetime.start] [Const -1 int64] $block
	    }
	    if {$type ne ""} {
		set block [$b cast(ptr) $block $type $name]
	    }
	    return $block
	}

	# Wrapper for the case where we're allocating a defined type.
	my closure cknew {type {name "ptr"}} {
	    tailcall my ckalloc [$b cast(int) [$b sizeof $type]] $type $name
	}
    }

    # ------------------------------------------------------------------
    #
    # ThunkBuilder:ckfree --
    #
    #	Free memory using Tcl's memory manager.
    #
    # Parameters:
    #	object -
    #		The LLVM value reference to the pointer to the memory to free.
    #
    # Results:
    #	None.

    method @macros.ckfree {} {
	my closure ckfree {object} {
	    set block [$b cast(ptr) $object char "ptr"]
	    if {[::tcl::pkgconfig get debug]} {
		set frameinfo [info frame -1]
		set file "/dev/null"
		if {[dict exists $frameinfo file]} {
		    set file [dict get $frameinfo file]
		}
		set file [$b constString $file "source.filename"]
		set line [Const [dict get $frameinfo line]]
		my Tcl_DbCkfree $block $file $line
	    } else {
		my Tcl_Free $block
	    }
	    if {![info exist ::env(NOASSERTS)]} {
		$b Call [$m intrinsic lifetime.end] [Const -1 int64] $block
	    }
	    return
	}
    }

    # ------------------------------------------------------------------
    #
    # ThunkBuilder:ckrealloc --
    #
    #	Reallocate memory using Tcl's memory manager.
    #
    # Parameters:
    #	block -	The LLVM value reference to the pointer to the memory to
    #		reallocate.
    #	size -	The desired size of the piece of memory. May be either a Tcl
    #		value or an LLVM value reference.
    #	type (optional) -
    #		The type description (human-readable) of the result. If
    #		omitted, the result will be a void* (strictly, an LLVM i8*).
    #
    # Results:
    #	LLVM value reference to pointer to the reallocated memory.

    method @macros.ckrealloc {size_t} {
	my closure ckrealloc {object size {name "ptr"}} {
	    if {[string is integer -strict $size]} {
		set size [Const $size $size_t]
	    }
	    set oldblock [$b cast(ptr) $object char "$name.old"]
	    if {[::tcl::pkgconfig get debug]} {
		set frameinfo [info frame -1]
		set file "/dev/null"
		if {[dict exists $frameinfo file]} {
		    set file [dict get $frameinfo file]
		}
		set file [$b constString $file "source.filename"]
		set line [Const [dict get $frameinfo line]]
		set newblock [my Tcl_DbCkrealloc $oldblock $size $file $line]
	    } else {
		set newblock [my Tcl_Realloc $oldblock $size]
	    }
	    SetValueName $newblock "$name.new"
	    if {![info exist ::env(NOASSERTS)]} {
		set flag [Const -1 int64]
		$b Call [$m intrinsic lifetime.end] $flag $oldblock
		$b Call [$m intrinsic lifetime.start] $flag $newblock
	    }
	    return [$b cast(ptr2ptr) $newblock [TypeOf $object] $name]
	}
    }

    # ------------------------------------------------------------------
    #
    # ThunkBuilder:obj.constant --
    #
    #	Create a "constant" Tcl_Obj. This injects the bootstrapping code for
    #	the Tcl_Obj into the binding thunk, and makes all other uses of the
    #	Tcl_Obj just be a 'load' of the relevant bootstrapped global variable.
    #	NOTE: the binding thunk itself must not use this method.
    #
    # Parameters:
    #	constant -
    #		The Tcl string containing the characters to use for
    #		the constant.
    #
    # Results:
    #	LLVM value reference to the Tcl_Obj*.

    method @macros.obj.constant {} {
	set f [$m local tcl.obj.constant Tcl_Obj*<-Tcl_Obj**,char*,int noinline]
	params theGlobal:varPtr theBytes:stringPtr theLength:length
	build {
	    noalias $theGlobal $theBytes
	    nonnull $theGlobal $theBytes
	    set theObj [$b load $theGlobal "objPtr"]
	    $b condBr [$b nonnull $theObj] $whenDefined $whenUndefined
	label whenDefined "defined"
	    $b ret $theObj
	label whenUndefined "undefined"
	    set theObj [my Tcl_NewStringObj $theBytes $theLength]
	    my Tcl_IncrRefCount $theObj
	    my Tcl_IncrRefCount $theObj
	    # FIXME deallocate when module unloaded
	    $b store $theObj $theGlobal
	    $b ret $theObj
	}

	my closure obj.constant {content} {
	    variable obj.constants
	    variable obj.constants.defined
	    variable obj.constants.pending
	    variable metathunkblock

	    set existing [info exist obj.constants($content)]

	    if {$existing} {
		set name [set obj.constants($content)]
	    } else {
		set name obj.constant.[array size obj.constants.defined]
		set obj.constants($content) $name
	    }

	    set name2 str[string trimleft $name obj]
	    set var [$m variable $name Tcl_Obj* [$b null Tcl_Obj*]]
	    set obj.constants.defined($name) $var

	    if {!$existing} {
		set str [$b constString $content $name2]
		set len [Const [string bytelength $content] int]
		if {[info exist metathunkblock]} {
		    my buildInSection initConstant {
			$metathunkblock build $b {
			    $b Call ${tcl.obj.constant} $var $str $len
			}
		    }
		} else {
		    lappend obj.constants.pending $var $str $len
		}
	    }

	    set obj [$b loadInvariant $var]
	    $b printref $obj "constant:"
	    $b assume [$b ge [$b refCount $obj] [Const 2]]
	    return $obj
	}

	# Initialise the variable to an array
	variable obj.constants.defined
	array set obj.constants.defined {}
    }

    # ------------------------------------------------------------------
    #
    # ThunkBuilder:jumptable.constant --
    #
    #	Create a jump table for the 'maptoint' opcode. This injects the
    #	bootstrapping code for the Tcl_Obj into the binding thunk.
    #
    # Parameters:
    #	constant -
    #		The Tcl string containing the dictionary mapping strings to
    #		small positive integers.
    #
    # Results:
    #	LLVM value reference to the Tcl_HashTable*.

    method @macros.jumptable.constant {} {
	set f [$m local "bootstrap.JumpTable.constant" \
		void<-Tcl_HashTable*,Tcl_Obj* noinline]
	params theHash:hashPtr theData:objPtr
	build {
	    noalias $theHash $theData
	    nonnull $theHash $theData
	    my Tcl_InitObjHashTable $theHash
	    set searchPtr [$b alloc Tcl_DictSearch "search"]
	    set keyPtr [$b alloc Tcl_Obj* "key"]
	    set valuePtr [$b alloc Tcl_Obj* "value"]
	    set donePtr [$b alloc int "done"]
	    set jumpPtr [$b alloc int "jump"]
	    my Tcl_DictObjFirst {} $theData $searchPtr \
		    $keyPtr $valuePtr $donePtr
	    $b condBr [$b eq [$b load $donePtr "done"] [Const 0]] \
		$loop $finished
	label loop:
	    set key [$b load $keyPtr "key"]
	    set value [$b load $valuePtr "value"]
	    my Tcl_GetIntFromObj {} $value $jumpPtr
	    set jump [$b load $jumpPtr "jump"]
	    set hPtr [my TclCreateHashEntry $theHash $key $donePtr]
	    my Tcl_SetHashValue $hPtr $jump
	    my Tcl_DictObjNext $searchPtr $keyPtr $valuePtr $donePtr
	    $b condBr [$b eq [$b load $donePtr "done"] [Const 0]] \
		$loop $finished
	label finished:
	    # FIXME clean up when module unloaded
	    my Tcl_DictObjDone $searchPtr
	    $b ret
	}

	my closure jumptable.constant {content} {
	    variable metathunkblock
	    variable jumptablecounter

	    # verify map to int
	    foreach v [dict values $content] {incr v 0}
	    set name jumptable.[incr jumptablecounter]
	    set var [$m variable $name Tcl_HashTable [$b undef Tcl_HashTable]]
	    my buildInSection initConstant {
		$metathunkblock build $b {
		    set init [my obj.constant $content]
		    set call [$b Call [$f ref] $var $init]
		    AddCallAttribute $call 1 nocapture
		    AddCallAttribute $call 2 nocapture
		}
	    }
	    return $var
	}
	oo::objdefine $b forward @jumptable.constant [self] jumptable.constant
    }

    method @macros {} {
	upvar 1 size_t size_t

	set inline {}
	if {[info exists ::env(TQC_AVOID_INLINING_MACROS)]} {
	    set inline noinline
	}
	my @macros.Tcl_IncrRefCount $inline
	my @macros.Tcl_DecrRefCount $inline
	my @macros.TclFreeIntRep $inline
	my @macros.TclInvalidateStringRep $inline
	my @macros.TclHashTable
	my @macros.ckalloc $size_t
	my @macros.ckfree
	my @macros.ckrealloc $size_t
	my @macros.obj.constant
	my @macros.jumptable.constant

	# ------------------------------------------------------------------
	#
	# ThunkBuilder:writeline --
	#
	#	Debugging helper that writes a string to standard out as its
	#	own line.
	#
	# Parameters:
	#	s -	The Tcl string to write.
	#
	# Results:
	#	None.

	set f [$m local writeline void<-char*,int noinline]
	my closure writeline s {
	    append s "\n"
	    $b Call writeline [$b constString $s] \
		[Const [string bytelength $s]]
	    return
	}
	params string length
	build {
	    nonnull $string
	    if {[info exists ::env(TQC_AVOID_MEMORY_IN_DEBUG_PRINT)]} {
		set signature func{int<-int,void*,int}
		set write [$m function.extern write [Type $signature]]
		$b call $write [list [Const 1] $string $length]
	    } else {
		set chan [my Tcl_GetStdChannel [Const [expr 1<<3]]]
		my Tcl_WriteChars $chan $string $length
	    }
	    $b ret
	}

	# ------------------------------------------------------------------
	#
	# ThunkBuilder:writeint --
	#
	#	Debugging helper that writes an unsigned 32-bit number to
	#	standard out as its own line. The number is written in
	#	hexadecimal with its digits in reverse order.
	#
	# Parameters:
	#	i -	The LLVM int32 to write.
	#	msg (optional) -
	#		An optional prefix string to write, useful for
	#		indicating which call site was generating the number.
	#		This is a Tcl string.
	#
	# Results:
	#	None.

	set f [$m local writeint void<-int noinline]
	params n
	if {[info exists ::env(TQC_AVOID_MEMORY_IN_DEBUG_PRINT)]} {
	    build {
		set s [$b constString "0123456789ABCDEF"]
		$b condBr [$b eq $n [Const 0]] $zero $num
	    label zero:
		$b Call writeline [$b getelementptr $s [Const 0]] [Const 1]
		$b br $done
	    label num:
		set nn [$b alloc int]
		$b store $n $nn
		$b br $test
	    label test:
		set n_ [$b load $nn]
		$b condBr [$b eq $n_ [Const 0]] $done $body
	    label body:
		set nd [$b div $n_ [Const 16]]
		set n0 [$b sub $n_ [$b mult $nd [Const 16]]]
		$b store $nd $nn
		$b Call writeline [$b getelementptr $s $n0] [Const 1]
		$b br $test
	    label done:
		my writeline ""
		$b ret
	    }
	} else {
	    build {
		set str [my Tcl_ObjPrintf [$b constString "0x%X"] $n]
		set chan [my Tcl_GetStdChannel [Const [expr 1<<3]]]
		my Tcl_WriteObj $chan $str
		my Tcl_DecrRefCount $str
		my writeline ""
		$b ret
	    }
	}
	my closure writeint {i {msg ""}} {
	    if {$msg ne ""} {
		$b Call writeline [$b constString $msg] \
		    [Const [string bytelength $msg]]
	    }
	    $b Call writeint $i
	}

	# ------------------------------------------------------------------
	#
	# ThunkBuilder:stork --
	#
	#	Helper for enforcement of Tcl's 'stork' property of Tcl_Objs,
	#	i.e., that values must always have at least one a string
	#	representation or an internal representation. Failures will
	#	make the code do a Tcl_Panic().
	#
	# Parameters:
	#	obj -	The LLVM Tcl_Obj* reference to check.
	#
	# Results:
	#	None.

	set f [$m local stork void<-Tcl_Obj* noinline readonly]
	params obj
	build {
	    $b condBr [$b or \
		    [$b nonnull [$b dereference $obj 0 Tcl_Obj.bytes]] \
		    [$b nonnull [$b dereference $obj 0 Tcl_Obj.typePtr]]] \
		$ok $fail
	label ok:
	    $b ret
	label fail:
	    my Tcl_Panic [$b constString "the stork fell over %p"] $obj
	    $b br $fail
	}
	my closure stork {obj} {
	    $b Call stork $obj
	    return
	}
    }
}

# Local Variables:
# mode: tcl
# fill-column: 78
# auto-fill-function: nil
# buffer-file-coding-system: utf-8-unix
# End:
