# 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 {}
# 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*]
}
^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:Tcl_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
set pieces [lassign [Split [lindex $m 1]] name]
set name [string trim $name]
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
} on error {} {
# Try the other way, see if this fixes self-reference issues
set index -1
set type [NamedStructType $name {} 0]
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]
}
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
}
}
# 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: