# 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]
}
if {$type eq ""} {
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: