# 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-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.
#
#------------------------------------------------------------------------------
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$" {
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$" {
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} {
switch -regexp -matchvar m -- [set t [string trim [string map {\n " "} $descriptor]]] {
{^void\s*\*$} {
# 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$ {
return [Type named{Tcl_Obj}*]
}
^INT$ - ^ENTIER$ - "^INT BOOLEAN$" - "^ZEROONE$" {
return [Type named{INT,kind:int,i32:int,i64:int64}]
}
^NUMERIC$ {
return [Type named{NUMERIC,kind:int,int:INT,double:DOUBLE}]
}
^FOREACH$ {
return [Type named{ForeachPair,val:int,max:int}]
}
^DICTITER$ {
return [Type "named{DictIter,
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]
}
{^VOID FAIL$} - {^VOID\?$} - {^FAIL$} - {^NEXIST$} -
{^NOTHING$} {
return [Type bool]
}
{^(.*) FAIL$} - {^FAIL (.*)} - {^(.*)\?$} - {^NEXIST (.*)$} {
return [Type struct{[Type bool],[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]
}
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
}
{^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)"
}
}
}
# 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 {uplevel 1 $script}]
if {$time > 0} {
puts "${phase}: [lrange $t 0 1]"
}
}
# 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} {
puts stderr [format "WARNING: $msg" {*}$args]
}
# 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
# End:
|