# compile.tcl --
#
# Engine that handles compiling and issuing code for a single Tcl
# procedure. Note that this needs to be done within the context of an
# LLVM module (which is approximately the same concept as a compilation
# unit in a language like C).
#
# Copyright (c) 2014-2017 by Donal K. Fellows
# Copyright (c) 2014-2015 by Kevin B. Kenny
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
#------------------------------------------------------------------------------
# Class TclCompiler --
#
# This class compiles a function derived from Tcl bytecode.
#
# Construction Parameters:
# none
#
# Public properties:
# none
oo::class create TclCompiler {
superclass llvmEntity
variable bytecode cmd func quads paramTypes returnType vtypes variables
variable m b pc errorCode
variable bytecodeVars namespace
constructor {} {
next
namespace import \
::quadcode::nameOfType \
::quadcode::typeOfLiteral \
::quadcode::typeOfOperand \
::quadcode::dataType::mightbea
namespace eval tcl {
namespace eval mathfunc {
proc literal {descriptor} {
string equal [lindex $descriptor 0] "literal"
}
proc refType {type} {
expr {
[uplevel 1 [list my ReferenceType? $type]]
&& "CALLFRAME" ni $type
}
}
proc failType {type} {
uplevel 1 [list my FailureType? $type]
}
proc operandType {operand} {
uplevel 1 [list my OperandType $operand]
}
proc consumed {var search} {
uplevel 1 [list my IsConsumed $var $search]
}
}
}
}
# TclCompiler:ByteCode --
#
# Sets the bytecode description dictionary that this compiler code
# generator will work with. Used for a number of things.
#
# Parameters:
# command -
# The name of the command being compiled.
# bytecode -
# The bytecode description dictionary being compiled.
#
# Results:
# None
method ByteCode {command bytecodeDict} {
set cmd $command
set bytecode $bytecodeDict
catch {
dict set bytecode argumentDefaults [lmap v [info args $cmd] {
set def ""
list $v [info default $cmd $v def] $def
}]
}
set bytecodeVars [dict get $bytecode variables]
set namespace [dict get $bytecode namespace]
return
}
# TclCompiler:InitTypeInfo --
#
# Sets the argument types, result type, and variable-type mapping for
# the quadcode.
#
# Parameters:
# argumentTypes -
# The Tcl list of typecodes, representing the arguments to the
# function in order.
# resultType -
# The typecode of the return type.
# typeMap -
# The variable-typecode mapping dictionary used to describe what
# the type of each variable in the quadcode is.
#
# Results:
# None
method InitTypeInfo {argumentTypes resultType typeMap} {
set vtypes $typeMap
set paramTypes $argumentTypes
set returnType $resultType
return
}
# TclCompiler:PrintTypedQuads --
#
# Print the sequence of typed quadcodes that the type inference engine
# has transformed the procedure into.
#
# Parameters:
# channel -
# Where to write the message.
# qs - The quadcode to print.
#
# Results:
# None.
method PrintTypedQuads {channel qs} {
set idx -1
set descriptions [lmap q $qs {
concat "[incr idx]:" $q ":" [linsert [lmap arg [lrange $q 1 end] {
try {
if {$arg eq ""} {
string cat VOID
} elseif {[string match {pc *} $arg]} {
string cat BLOCK
} else {
my ValueTypes $arg
}
} on error {} {
string cat VOID
}
}] 1 \u21d0]
}]
if {$channel eq ""} {
return [format "%s------>\n%s" $cmd [join $descriptions \n]]
} else {
puts $channel [format "%s------>\n%s" $cmd [join $descriptions \n]]
}
}
# TclCompiler:generateDeclaration --
#
# Generate the declaration for the function that we are transforming the
# Tcl code into.
#
# Parameters:
# module -
# The module reference (i.e., instance of Module class) to
# generate the function within.
#
# Results:
# The function reference (i.e., instance of Function class) that we have
# generated. Note that this will be an unimplemented function at this
# stage.
method generateDeclaration {module} {
set m $module
##############################################################
#
# Compute the argument types
#
set argl {}
set argn {}
foreach typecode $paramTypes {
set type [nameOfType $typecode]
lappend argn $type
lappend argl [Type $type]
}
##############################################################
#
# Compute the return type
#
set rtype [nameOfType $returnType]
set returntype [Type $rtype]
##############################################################
#
# Construct the function signature type and the function object.
#
set ft [llvmtcl FunctionType $returntype $argl 0]
dict set bytecode signature [list $rtype $argn]
set realname [my GenerateFunctionName $cmd typecodes $paramTypes]
# Check if the function already exists; that indicates serious
# problems in the caller.
if {[$m function.defined $realname]} {
return -code error "duplicate $cmd"
}
set func [$m function.create $realname $ft]
return $func
}
# TclCompiler:Compile --
#
# Generate the body for the function that we are transforming the Tcl
# code into.
#
# Parameters:
# quadcode -
# The quadcode that defines the Tcl code we are translating.
#
# Results:
# The LLVM function reference that we have generated.
method Compile {quadcode} {
set quads $quadcode
namespace upvar ::quadcode::dataType STRING STRING
##############################################################
#
# Create builder, basic blocks and error code context
#
set b [$m builder]
if {[dict exists $bytecode sourcefile]} {
$m debug file [dict get $bytecode sourcefile]
}
$func setAsCurrentDebuggingScope
lassign [my GenerateBasicBlocks $quads] blockDict ipathDict pred
array set block $blockDict
array set ipath $ipathDict
# NB: block(-1) is the function entry block. It's supposed to be
# almost entirely optimized out.
$block(-1) build-in $b
$b @location 0
set errorCode [$b alloc int "tcl.errorCode"]
set curr_block $block(-1)
set 0 [$b int 0]
##############################################################
#
# Create stubs for variables in LLVM; because of loops, uses may occur
# before a variable is written to.
#
dict for {name typecode} $vtypes {
lassign $name kind formalname origin
set type [nameOfType $typecode]
# Make the debugging information for the variable provided it is a
# variable as perceived from the Tcl level. "Internal" temporary
# variables aren't nearly so interesting.
if {$kind eq "var"} {
if {[lindex $quads $origin 0] eq "param"} {
set idx [lsearch $bytecodeVars \
[list "scalar arg" $formalname]]
if {$idx < 0} {
return -code error \
"unmapped formal variable name: $formalname ($name)"
}
$func param $idx $formalname
} else {
# Not a parameter; set up the debugging metadata as a
# local variable.
$func localvar [lindex $name 1] $type
}
}
# This is awful, but these *must* be unique things to replace, so
# we make them be individual loads of a memory location that has
# never been written to. This prevents them from being coalesced
# too early by the constant management engine; merely using an
# undef would make disparate values become unified.
#
# It is a major problem if any of these actually survives the
# optimisation phase.
#
# This cannot be left until the first reference to the variable;
# that might be from a phi, and those must be first in their basic
# blocks.
if {![info exist undefs($type)]} {
set tycode [expr {$type eq "VOID" ? "void*" : $type}]
set undefs($type) [$b alloc $tycode "undef.$type"]
}
set variables($name) [$b load $undefs($type) "undef.$formalname"]
}
##############################################################
#
# Convert Tcl parse output, one instruction at a time.
#
set pc -1
set ERROR_TEMPLATE "\n (compiling \"%s\" @ pc %d: %s)"
set phiAnnotations {}
set theframe {}
set thevarmap {}
set currentline 0
foreach l $quads {
incr pc
if {[info exists block($pc)]} {
$block($pc) build-in $b
set curr_block $block($pc)
set consumed {}
}
unset -nocomplain tgt
##########################################################
#
# Issue the code for a single quadcode instruction.
#
try {
$b @location $currentline
switch -exact -- [lindex $l 0 0] {
"entry" {
lassign $l opcode tgt vars
if {![dict exists $bytecode procmeta]} {
dict set bytecode procmeta \
[$m variable [list procmeta $cmd] Proc* \
[$b null Proc*]]
}
set procmeta [dict get $bytecode procmeta]
lassign [$b frame.create [lindex $vars 1] \
[Const 0] [$b null STRING*] \
[$b load $procmeta "proc.metadata"]]\
theframe thevarmap
my StoreResult $tgt $theframe
}
"confluence" - "unset" {
# Do nothing; required for SSA computations only
}
"@debug-line" {
lassign $l opcode - src
set currentline [lindex $src 1]
}
"@debug-value" {
# Debugging directive mapping value in quadcode to Tcl
# source variable; except we don't do that any more.
# Instead, a general "assign to something that looks like
# a variable" is good enough anyway, and that is handled
# in TclCompiler:StoreResult.
my Warn "unexpected @debug-value opcode at ${cmd}:$pc"
}
"param" {
lassign $l opcode tgt src
set idx [lindex $src 1]
set name [lindex $tgt 1]
set var [$func param $idx $name]
set variables($tgt) $var
set type [my OperandType $tgt]
if {[regexp {^IMPURE } $type]} {
set var [$b stringifyImpure $var]
set type STRING
}
if {refType($type)} {
$b printref $var "param:"
$b addReference($type) $var
$b assume [$b shared $var]
}
}
"moveToCallFrame" {
set mapping [lassign $l opcode tgt src]
foreach {name value} $mapping {
set name [lindex $name 1]
set var [dict get $thevarmap $name]
if {$value ne "Nothing"} {
set op frame.store([my ValueTypes $value])
set value [my LoadOrLiteral $value]
$b $op $value $theframe $var $name
} else {
$b frame.unset $theframe $var $name
}
}
my StoreResult $tgt [my LoadOrLiteral $src]
}
"retrieveResult" {
lassign $l opcode tgt src
if {[my ValueTypes $src] eq "CALLFRAME"} {
set value [$b undef NOTHING]
} else {
set value [$b frame.value [my LoadOrLiteral $src]]
}
my StoreResult $tgt $value
}
"extractCallFrame" {
lassign $l opcode tgt src
set value [my LoadOrLiteral $src]
if {[my ValueTypes $src] ne "CALLFRAME"} {
set name [my LocalVarName $tgt]
set value [$b frame.frame $value $name]
}
my StoreResult $tgt $value
}
"moveFromCallFrame" {
lassign $l opcode tgt src varname
set name [my LocalVarName $tgt]
set vname [lindex $varname 1]
set var [dict get $thevarmap $vname]
my StoreResult $tgt \
[$b frame.load $theframe $var $vname $name]
}
"returnOptions" - "result" {
set srcs [lassign $l opcode tgt]
set name [my LocalVarName $tgt]
set srctype [my ValueTypes [lindex $srcs 0]]
if {"CALLFRAME" in $srctype} {
set srcs [lrange $srcs 1 end]
}
append opcode ( [my ValueTypes {*}$srcs] )
set srcs [lmap s $srcs {my LoadOrLiteral $s}]
my StoreResult $tgt [$b $opcode {*}$srcs $name]
}
"bitor" - "bitxor" - "bitand" - "lshift" - "rshift" -
"add" - "sub" - "mult" - "uminus" - "uplus" - "land" - "lor" -
"isBoolean" - "eq" - "neq" - "lt" - "gt" - "le" - "ge" -
"streq" - "bitnot" - "strcase" - "strclass" - "strcmp" -
"strfind" - "strlen" - "strmap" - "strmatch" - "strrfind" -
"strtrim" - "resolveCmd" {
set srcs [lassign $l opcode tgt]
set name [my LocalVarName $tgt]
append opcode ( [my ValueTypes {*}$srcs] )
set srcs [lmap s $srcs {my LoadOrLiteral $s}]
my StoreResult $tgt [$b $opcode {*}$srcs $name]
}
"originCmd" {
set srcs [lassign $l opcode tgt]
set name [my LocalVarName $tgt]
append opcode ( [my ValueTypes {*}$srcs] )
set srcs [lmap s $srcs {my LoadOrLiteral $s}]
my StoreResult $tgt [$b $opcode {*}$srcs $errorCode $name]
}
"list" {
set srcs [lassign $l opcode tgt]
set name [my LocalVarName $tgt]
set types [split [my ValueTypes {*}$srcs] ,]
set srcs [lmap s $srcs {my LoadOrLiteral $s}]
my StoreResult $tgt [$b list $srcs $types $name]
}
"strindex" {
set srcs [lassign $l opcode tgt]
set name [my LocalVarName $tgt]
set srcs [my ConvertIndices 0 strlen 1]
my StoreResult $tgt [$b $opcode {*}$srcs $errorCode $name]
}
"strrange" - "strreplace" {
set srcs [lassign $l opcode tgt]
set name [my LocalVarName $tgt]
set srcs [my ConvertIndices 0 strlen 1 2]
my StoreResult $tgt [$b $opcode {*}$srcs $errorCode $name]
}
"regexp" - "listAppend" - "listConcat" - "listLength" -
"listRange" - "listIn" - "listNotIn" - "dictIterStart" -
"dictAppend" - "dictIncr" - "dictLappend" - "dictSize" -
"div" - "expon" - "mod" - "not" {
set srcs [lassign $l opcode tgt]
set name [my LocalVarName $tgt]
append opcode ( [my ValueTypes {*}$srcs] )
set srcs [lmap s $srcs {my LoadOrLiteral $s}]
my StoreResult $tgt [$b $opcode {*}$srcs $errorCode $name]
}
"returnCode" {
lassign $l opcode tgt
set name [my LocalVarName $tgt]
my StoreResult $tgt [$b packInt32 [$b load $errorCode] $name]
}
"initException" {
my IssueException $l
}
"setReturnCode" {
lassign $l opcode - src
$b store [$b getInt32 [my LoadOrLiteral $src]] $errorCode
}
"dictExists" {
my IssueDictExists $l
}
"dictGet" - "dictUnset" - "listIndex" {
set srcs [lassign $l opcode tgt srcObj]
set name [my LocalVarName $tgt]
if {[llength $srcs] == 1} {
# Simple case
set srcs [list $srcObj {*}$srcs]
append opcode ( [my ValueTypes {*}$srcs] )
set srcs [lmap s $srcs {my LoadOrLiteral $s}]
my StoreResult $tgt [$b $opcode {*}$srcs $errorCode $name]
} else {
# Need to construct the variadic path
set vectortypes [lmap s $srcs {my ValueTypes $s}]
set vector [$b buildVector $vectortypes \
[lmap s $srcs {my LoadOrLiteral $s}]]
append opcode ( [my ValueTypes $srcObj] )
set srcObj [my LoadOrLiteral $srcObj]
my StoreResult $tgt [$b $opcode $srcObj $vector $errorCode $name]
$b clearVector $srcs $vector $vectortypes
}
}
"dictSet" - "listSet" {
set srcs [lassign $l opcode tgt srcObj srcValue]
set name [my LocalVarName $tgt]
if {[llength $srcs] == 1} {
# Simple case
set srcs [list $srcObj {*}$srcs $srcValue]
append opcode ( [my ValueTypes {*}$srcs] )
set srcs [lmap s $srcs {my LoadOrLiteral $s}]
my StoreResult $tgt [$b $opcode {*}$srcs $errorCode $name]
} else {
# Need to construct the variadic path
set vectortypes [lmap s $srcs {my ValueTypes $s}]
set vector [$b buildVector $vectortypes \
[lmap s $srcs {my LoadOrLiteral $s}]]
set srcs [list $srcObj $srcValue]
append opcode ( [my ValueTypes {*}$srcs] )
set srcs [lmap s $srcs {my LoadOrLiteral $s}]
my StoreResult $tgt [$b $opcode {*}$srcs $vector $errorCode $name]
$b clearVector $srcs $vector $vectortypes
}
}
"copy" {
lassign $l opcode tgt src
set value [my LoadOrLiteral $src]
set type [my OperandType $tgt]
set name [my LocalVarName $tgt]
SetValueName $value $name
if {refType($type)} {
$b addReference($type) $value
$b printref $value "copy:"
}
my StoreResult $tgt $value
}
"maptoint" {
lassign $l opcode tgt src map def
set map [lindex $map 1]
set def [lindex $def 1]
set name [my LocalVarName $tgt]
append opcode ( [my ValueTypes $src] )
set src [my LoadOrLiteral $src]
my StoreResult $tgt [$b $opcode $src $map $def $name]
}
"extractExists" - "extractMaybe" {
my IssueExtract $l
}
"free" {
lassign $l opcode tgt src
set type [my OperandType $src]
if {$src ni $consumed} {
if {$type eq "VOID"} {
# VOID is trivial to free
} elseif {refType($type)} {
$b printref $variables($src) "free:"
$b dropReference([my ValueTypes $src]) $variables($src)
}
lappend consumed $src
}
}
"exists" {
lassign $l opcode tgt src
set type [my OperandType $src]
if {$type eq "NEXIST"} {
set value [Const false bool]
} elseif {!failType($type)} {
set value [Const true bool]
} else {
set value [$b exists [my LoadOrLiteral $src]]
}
my StoreResult $tgt $value
}
"jumpMaybe" {
lassign $l opcode tgt src
set tgt [lindex $tgt 1]
if {failType(operandType($src))} {
set test [my Unlikely maybe [my LoadOrLiteral $src]]
$b condBr $test $block($tgt) $ipath($pc)
} else {
# Non-FAIL types never take the branch
$b br $ipath($pc)
}
}
"jumpMaybeNot" {
lassign $l opcode tgt src
set tgt [lindex $tgt 1]
if {failType(operandType($src))} {
set test [my Unlikely maybe [my LoadOrLiteral $src]]
$b condBr $test $ipath($pc) $block($tgt)
} else {
# Non-FAIL types always take the branch
$b br $block($tgt)
}
}
"jumpTrue" {
lassign $l opcode tgt src
set name [my LocalVarName $src]
set tgt [lindex $tgt 1]
set neq neq([my ValueTypes $src],INT)
set test [$b $neq [my LoadOrLiteral $src] $0 test_$name]
$b condBr $test $block($tgt) $ipath($pc)
}
"jumpFalse" {
lassign $l opcode tgt src
set name [my LocalVarName $src]
set tgt [lindex $tgt 1]
set neq neq([my ValueTypes $src],INT)
set test [$b $neq [my LoadOrLiteral $src] $0 test_$name]
$b condBr $test $ipath($pc) $block($tgt)
}
"jump" {
$b br $block([lindex $l 1 1])
}
"return" {
lassign $l opcode -> frame src
set vt [my ValueTypes $src]
set val [my LoadOrLiteral $src]
if {"CALLFRAME" in $vt} {
set val [$b frame.value $val]
}
set type [nameOfType $returnType]
if {refType($type)} {
$b printref $val "ret:"
if {literal($src)} {
$b addReference($type) $val
}
}
if {$theframe ne ""} {
$b frame.release $theframe
}
$b ret $val
}
"returnException" {
lassign $l opcode -> callframe code
if {$theframe ne ""} {
$b frame.release $theframe
}
# A VOID, a FAIL, a NEXIST, are all things that are not
# strings.
if {![mightbea $returnType $STRING]} {
$b ret [Const true bool]
} else {
set type [nameOfType $returnType]
$b ret [$b nothing $type]
}
}
"phi" {
set values {}
set sources {}
foreach {var origin} [lassign $l opcode tgt] {
set spc [lindex $origin end]
while {![info exists block($spc)]} {incr spc -1}
set s $block($spc)
if {$s ni [dict get $pred $curr_block]} {
my Warn "%s not predecessor to %s in %s; skipping..." \
[$s name] [$curr_block name] $cmd
continue
}
lappend sources $s
lappend values [my LoadOrLiteral $var]
}
set name phi_[my LocalVarName $tgt]
set value [$b phi $values $sources $name]
my StoreResult $tgt $value "phi"
if {[lindex $quads [expr {$pc+1}] 0 0] ne "phi"} {
foreach {name value} $phiAnnotations {
my AnnotateAssignment $name $value
}
set phiAnnotations {}
}
}
"invoke" {
set arguments [my IssueInvoke $theframe $l]
foreach aa $arguments {
set arguments [lassign $arguments a]
if {$a ni $arguments && consumed($a, $pc + 1)} {
lappend consumed $a
}
}
}
"strcat" {
set srcs [lassign $l opcode tgt src1]
set name [my LocalVarName $tgt]
set type [my OperandType $src1]
set val [my LoadOrLiteral $src1]
if {!refType($type)} {
set result [$b stringify($type) $val $name]
$b addReference(STRING) $result
} elseif {$src1 ni $srcs && consumed($src1, $pc + 1)} {
set result [$b unshare($type) $val $name]
lappend consumed $src1
} else {
set result [$b unshareCopy($type) $val $name]
}
$b printref $result "cat:"
foreach src $srcs {
set val [my LoadOrLiteral $src]
$b appendString([my ValueTypes $src]) $val $result
}
my StoreResult $tgt $result
}
"concat" {
set srcs [lassign $l opcode tgt]
# Need to construct the variadic vector
set vectortypes [lmap s $srcs {my ValueTypes $s}]
set vector [$b buildVector $vectortypes \
[lmap s $srcs {my LoadOrLiteral $s}]]
set name [my LocalVarName $tgt]
set result [$b concat() $vector $name]
my StoreResult $tgt $result
$b clearVector $srcs $vector $vectortypes
}
"foreachStart" {
set srcs [lassign $l opcode tgt assign]
set listtypes [lmap s $srcs {my ValueTypes $s}]
set lists [$b buildVector $listtypes \
[lmap s $srcs {my LoadOrLiteral $s}]]
set result [$b foreachStart [lindex $assign 1] $lists $errorCode]
my StoreResult $tgt $result
}
"unshareList" -
"foreachIter" - "foreachAdvance" - "foreachMayStep" -
"dictIterKey" - "dictIterValue" - "dictIterDone" -
"dictIterNext" {
lassign $l opcode tgt src
set name [my LocalVarName $tgt]
set result [$b $opcode [my LoadOrLiteral $src] $name]
my StoreResult $tgt $result
}
"widenTo" {
lassign $l opcode tgt src
my IssueWiden $l
}
"initIfNotExists" {
my IssueValueInit $l
}
"throwIfNotExists" {
set test [my IssueThrowIfNEXIST $l]
$b condBr $test $block($tgt) $ipath($pc)
}
"throwNotExists" {
lassign $l opcode tgt varname
set name [my LiteralValue $varname]
set msg "can't read \"$name\": no such variable"
set exn [list TCL LOOKUP VARNAME $name]
set msg [Const $msg STRING]
set exn [Const $exn STRING]
$b initException $exn $msg $errorCode
$b br $block([lindex $tgt 1])
}
"instanceOf" - "narrowToType" {
lassign $l opcode tgt src
lassign $opcode opcode - type
set name [my LocalVarName $tgt]
set type2 [my OperandType $src]
if {$type eq $type2} {
if {$opcode eq "instanceOf"} {
set value [$b int 1]
} else {
set value [my LoadOrLiteral $src]
if {refType($type)} {
$b printref $value "trivial-narrow:"
$b addReference($type) $value
}
}
} elseif {"NOTHING" in $type} {
# Should be an unreachable path
set value [$b undef $type]
} else {
set type [string map {" " _} $type]
append opcode . $type ( $type2 )
set value [$b $opcode [my LoadOrLiteral $src] $name]
}
my StoreResult $tgt $value
}
"checkArithDomain" {
lassign $l opcode tgt src opname
lassign $opcode opcode - type
set tgt [lindex $tgt 1]
set msg [format \
"can't use non-numeric string as operand of \"%s\"" \
[my LiteralValue $opname]]
set exn "ARITH DOMAIN {non-numeric string}"
set type2 [my OperandType $src]
if {$type eq $type2} {
$b br $ipath($pc)
} else {
append opcode . $type ( [my OperandType $src] )
set msg [Const $msg STRING]
set exn [Const $exn STRING]
set jmp [my Unlikely $opcode [my LoadOrLiteral $src] \
$msg $exn $errorCode "parse.failed"]
$b condBr $jmp $block($tgt) $ipath($pc)
}
}
"throwArithDomainError" {
lassign $l opcode tgt src opname
set msg [format \
"can't use non-numeric string as operand of \"%s\"" \
[my LiteralValue $opname]]
set exn "ARITH DOMAIN {non-numeric string}"
set msg [Const $msg STRING]
set exn [Const $exn STRING]
$b initException $exn $msg $errorCode
$b br $block([lindex $tgt 1])
}
"checkFunctionParam" - "narrowToParamType" -
"narrowToNotParamType" {
# These are supposed to never reach here; assert it
return -code error \
"opcode '[lindex $opcode 0]' sent to code issuer"
}
default {
return -code error "$cmd: unknown opcode '[lindex $l 0 0]' in '$l'"
}
}
} on error {msg opts} {
dict append opts -errorinfo \
[format $ERROR_TEMPLATE $cmd $pc $l]
return -options $opts $msg
} on return {msg opts} {
if {[dict get $opts -code] == 1} {
dict set opts -errorinfo $msg
dict append opts -errorinfo \
[format $ERROR_TEMPLATE $cmd $pc $l]
}
return -options $opts $msg
}
}
$b @loc {}
##############################################################
#
# Set increment paths, so that where we have a basic block that just
# falls through to its successor (not permitted in LLVM IR) we convert
# it to an explicit jump.
#
set maxpc $pc
foreach {pc blk} [array get block] {
if {[$blk terminated]} continue
while {[incr pc] <= $maxpc} {
if {[info exists block($pc)]} {
$blk build $b {
$b br $block($pc)
}
break
}
}
}
##############################################################
#
# Cleanup and return
#
$func verify
return [$func ref]
}
# TclCompiler:GenerateBasicBlocks --
#
# Generate the basic blocks for a function being compiled from Tcl
# code. Called from compile.
#
# Parameters:
# quads - The quadcode describing the function to compile.
#
# Results:
# A list of three dictionaries. The first dictionary maps program
# counters to basic blocks (using the PC that corresponds to the first
# instruction in the basic block; -1 designates the special "function
# entry" block that is reserved for the code issuer). The second
# dictionary says which block contains the next instruction (necessary
# for forking jumps); i.e., the Instruction Path. The third says which
# blocks are the predecessors of the current block.
method GenerateBasicBlocks {quads} {
# Instructions that will always jump.
set JUMPS {jump throwNotExists throwArithDomainError}
# Instructions that can go to either the next instruction OR the named
# instruction.
set FORKJUMPS {
jumpFalse jumpTrue
jumpMaybe jumpMaybeNot
checkArithDomain
throwIfNotExists
}
# Instructions that terminate execution of the function.
set EXITS {return returnException}
##############################################################
#
# Create basic blocks
#
set block(-1) [$func block]
set next_is_ipath 1
set pc -1
foreach q $quads {
incr pc
set opcode [lindex $q 0 0]
if {$next_is_ipath >= 0} {
if {![info exists block($pc)]} {
set block($pc) [$func block "pc.$pc"]
}
set ipath($next_is_ipath) $pc
set next_is_ipath -1
}
if {$opcode in $JUMPS || $opcode in $FORKJUMPS} {
# opcode {pc addr} ...
set tgt [lindex $q 1 1]
if {![info exists block($tgt)]} {
set block($tgt) [$func block "pc.$tgt"]
}
set next_is_ipath $pc
} elseif {$opcode in $EXITS} {
set next_is_ipath $pc
}
}
##############################################################
#
# Compute the predecessors of each basic block
#
set pc -1
set pred {}
set cb $block(-1)
foreach q $quads {
incr pc
if {![info exist cb]} {
set cb $block($pc)
} elseif {[info exist block($pc)]} {
dict lappend pred $block($pc) $cb
set cb $block($pc)
}
set opcode [lindex $q 0 0]
if {$opcode in $JUMPS} {
dict lappend pred $block([lindex $q 1 1]) $cb
unset cb
} elseif {$opcode in $FORKJUMPS} {
dict lappend pred $block([lindex $q 1 1]) $cb
dict lappend pred $block([expr {$pc + 1}]) $cb
unset cb
} elseif {$opcode in $EXITS} {
unset cb
}
}
##############################################################
#
# Dereference the ipaths.
#
set idict {}
foreach pc [array names ipath] {
dict set idict $pc $block($ipath($pc))
}
list [array get block] $idict $pred
}
# TclCompiler:IssueInvoke --
#
# Generate the code for invoking another Tcl command. Must only be
# called from the 'compile' method.
#
# Parameters:
# callframe -
# The callframe.
# operation -
# The quadcode descriptor for the instruction.
#
# Results:
# The set of arguments that might have been consumed in the operation
# (for cleanup by the caller of this method).
method IssueInvoke {callframe operation} {
set arguments [lassign $operation opcode tgt thecallframe origname]
set vname [my LocalVarName $tgt]
set BASETYPES {ZEROONE INT DOUBLE NUMERIC STRING}
# Is this a literal name for a function we already know the signature
# of? If so, we can use a direct call. To work this out, we need to
# resolve the command within the namespace context of the procedure.
if {literal($origname)} {
# Resolve the name.
set name [my FuncName [lindex $origname 1]]
set fullname [my GenerateFunctionName $name arguments $arguments]
if {[$m function.defined $fullname]} {
set called [[$m function.get $fullname] ref]
set argvals [lmap arg $arguments {my LoadOrLiteral $arg}]
set result [$b call $called $argvals $vname]
# FIXME: Assumes that called commands produce either TCL_OK or
# TCL_ERROR. That Ain't Necessarily So...
set ts [lmap t $BASETYPES {Type $t?}]
if {[TypeOf $result] in $ts} {
set ec [$b cast(uint) [$b maybe $result]]
$b store $ec $errorCode
} elseif {[Type [TypeOf $result]?] eq [Type [my ValueTypes $tgt]]} {
# Managed to prove non-failure in this case...
set result [$b just $result]
}
my StoreResult $tgt [$b frame.pack $callframe $result]
return {}
}
if {[dict exist $vtypes $tgt]} {
set type [nameOfType [dict get $vtypes $tgt]]
if {"FAIL" ni $type || "STRING" ni $type} {
my Warn "didn't find implementation of '$fullname'"
}
}
set origname [list literal $name]
}
set arguments [list $origname {*}$arguments]
set argvals [lmap s $arguments {my LoadOrLiteral $s}]
# Dynamic dispatch via direct call is OK, *provided* someone has
# fetched the function reference for us.
if {[TypeOf [lindex $argvals 0]] ne [Type STRING]} {
set argvals [lassign $argvals called]
set result [$b call $called $argvals $vname]
# FIXME: Assumes that called commands produce either TCL_OK or
# TCL_ERROR. That Ain't Necessarily So...
set ts [lmap t $BASETYPES {Type $t?}]
if {[TypeOf $result] in $ts} {
set ec [$b cast(uint) [$b maybe $result]]
$b store $ec $errorCode
}
my StoreResult $tgt [$b frame.pack $callframe $result]
return {}
}
# Must dispatch via the Tcl command API. This is the slowest option
# with the least type inference possible (everything goes as a
# STRING) but it is a reasonable fallback if nothing else works.
set types [lmap s $arguments {my ValueTypes $s}]
set vector [$b buildVector $types $argvals]
# TODO: Pass in the resolution context (namespace ref).
# TODO: Make the invoke do something sensible with that namespace
# reference (if provided).
set result [$b invoke $vector $errorCode $vname]
my StoreResult $tgt [$b frame.pack $callframe $result]
$b clearVector $arguments $vector $types
return $arguments
}
# TclCompiler:IssueWiden --
#
# Generate the code for widening the type of a value. Must only be
# called from the 'compile' method.
#
# Parameters:
# operation -
# The quadcode descriptor for the instruction.
#
# Results:
# none
method IssueWiden {operation} {
lassign $operation opcode tgt src
set name [my LocalVarName $tgt]
set srctype [my ValueTypes $src]
set tgttype [lindex $opcode 2]
if {$tgttype eq ""} {
set tgttype [my OperandType $tgt]
}
if {$srctype in {"VOID" "NOTHING" "NEXIST"}} {
switch -glob -- $tgttype {
"FAIL *" - "NEXIST *" {
set t [lrange $tgttype 1 end]
set value [$b nothing $t $name]
}
"STRING" - "EMPTY" {
set value [my LoadOrLiteral "literal {}"]
}
default {
# Should be unreachable in practice
set value [$b undef $tgttype]
}
}
} else {
set value [my LoadOrLiteral $src]
set value [my WidenedComplexValue $value $srctype $tgttype]
}
SetValueName $value $name
if {refType($tgttype)} {
$b addReference($tgttype) $value
$b printref $value "widen:"
}
my StoreResult $tgt $value
return
}
# Handles the type modifiers CALLFRAME, FAIL and NEXIST
method WidenedComplexValue {value srctype tgttype {name ""}} {
# Handle CALLFRAME-extended types
if {"CALLFRAME" eq $srctype && "CALLFRAME" in $tgttype} {
set frame $value
set value [$b undef [lrange $tgttype 1 end]]
return [$b frame.pack $frame $value $name]
} elseif {"CALLFRAME" in $srctype && "CALLFRAME" in $tgttype} {
set frame [$b frame.frame $value]
set value [$b frame.value $value]
set srctype [lrange $srctype 1 end]
set tgttype [lrange $tgttype 1 end]
set value [my WidenedComplexValue $value $srctype $tgttype]
return [$b frame.pack $frame $value $name]
} elseif {"CALLFRAME" in $tgttype} {
error "callframe injection"
}
# Handle FAIL-extended types
if {"FAIL" in $srctype && "FAIL" in $tgttype} {
set value [$b unmaybe $value]
set srctype [lrange $srctype 1 end]
set tgttype [lrange $tgttype 1 end]
set value [my WidenedComplexValue $value $srctype $tgttype]
return [$b just $value $name]
} elseif {"FAIL" in $tgttype} {
set tgttype [lrange $tgttype 1 end]
set value [my WidenedComplexValue $value $srctype $tgttype]
return [$b just $value $name]
}
# Handle NEXIST-extended types
if {"NEXIST" in $srctype && "NEXIST" in $tgttype} {
set value [$b unmaybe $value]
set srctype [lrange $srctype 1 end]
set tgttype [lrange $tgttype 1 end]
set value [my WidenedComplexValue $value $srctype $tgttype]
return [$b just $value $name]
} elseif {"NEXIST" in $tgttype} {
set tgttype [lrange $tgttype 1 end]
set value [my WidenedComplexValue $value $srctype $tgttype]
return [$b just $value $name]
}
# Delegate to the inner value handler
tailcall my WidenedValue $value $srctype $tgttype $name
}
# Handle widening of basic values
method WidenedValue {value srctype tgttype {name ""}} {
if {$srctype eq $tgttype} {
return $value
}
if {$srctype eq "ZEROONE" && "ZEROONE" ni $tgttype} {
set value [$b cast(BOOLEAN) $value]
set srctype INT
}
# IMPURE to IMPURE - Copy the string value, and promote the
# inner value
if {[lindex $tgttype 0] eq "IMPURE"
&& [lindex $srctype 0] eq "IMPURE"} {
set itgttype [lrange $tgttype 1 end]
set isrctype [lrange $srctype 1 end]
set ivalue [my WidenedValue [$b impure.value $value] \
$isrctype $itgttype]
set svalue [$b impure.string $value]
set value [$b impure $itgttype $svalue $ivalue $name]
} elseif {[lindex $srctype 0] eq "IMPURE" && "STRING" in $tgttype} {
set value [$b stringifyImpure $value $name]
} elseif {[regexp {^IMPURE (.*)$} $tgttype -> innertype]} {
set widened [my WidenedValue $value $srctype $innertype]
set value [$b packImpure($innertype) $widened $name]
} elseif {$tgttype eq "ZEROONE BOOLEAN"} {
if {$srctype in {"ZEROONE" "BOOLEAN"}} {
# do nothing - the internal reps are the same
}
} elseif {refType($tgttype) != refType($srctype)} {
# TODO: handle other kinds of reference types
set value [$b stringify($srctype) $value $name]
} elseif {$tgttype eq "DOUBLE"} {
set value [$b cast(DOUBLE) $value $name]
} elseif {$tgttype eq "NUMERIC"} {
if {$srctype eq "DOUBLE"} {
set value [$b packNumericDouble $value $name]
} else {
set value [$b packNumericInt $value $name]
}
} elseif {$srctype eq "EMPTY" && $tgttype eq "STRING"} {
set value [Const "" STRING]
} elseif {$srctype ne $tgttype} {
my Warn "unimplemented convert from '$srctype' to '$tgttype'"
}
if {[Type $tgttype] eq [Type [TypeOf $value]?]} {
set value [$b just $value]
}
return $value
}
# TclCompiler:IssueDictExists --
#
# Generate the code for testing whether an element of a dictionary
# exists. Must only be called from the 'compile' method. Includes some
# special hacks to handle bootstrapping arrays.
#
# Parameters:
# operation -
# The quadcode descriptor for the instruction.
#
# Results:
# none
method IssueDictExists {operation} {
set srcs [lassign $operation opcode tgt srcDict]
# Simple, common case
if {[llength $srcs] == 1} {
set srcs [list $srcDict {*}$srcs]
set name [my LocalVarName $tgt]
append opcode ( [my ValueTypes {*}$srcs] )
set srcs [lmap s $srcs {my LoadOrLiteral $s}]
my StoreResult $tgt [$b $opcode {*}$srcs $name]
return
}
# Verification of basic literal; two special cases
if {[llength $srcs] == 0 && $srcDict eq "literal {}"} {
my StoreResult $tgt [my LoadOrLiteral "literal 1"]
return
} elseif {[llength $srcs] == 0 && $srcDict eq "literal \uf8ff"} {
my StoreResult $tgt [my LoadOrLiteral "literal 0"]
return
}
# Need to construct the variadic vector
set types [lmap s $srcs {my ValueTypes $s}]
set vector [$b buildVector $types \
[lmap s $srcs {my LoadOrLiteral $s}]]
set name [my LocalVarName $tgt]
append opcode ( [my ValueTypes $srcDict] )
set srcDict [my LoadOrLiteral $srcDict]
my StoreResult $tgt [$b $opcode $srcDict $vector $name]
$b clearVector $srcs $vector $types
return
}
# TclCompiler:IssueExtract --
#
# Generate the code for exactracting the value of a variable which
# contains a "possibly-existing" value. Must only be called from the
# 'compile' method.
#
# Parameters:
# operation -
# The quadcode descriptor for the instruction.
#
# Results:
# none
method IssueExtract {operation} {
lassign $operation opcode tgt src
set name [my LocalVarName $tgt]
set tgttype [my OperandType $tgt]
set srctype [my OperandType $src]
# How to do the extraction depends on the type
if {$tgttype eq "NOTHING"} {
set value [Const 0 bool]
} elseif {failType($srctype)} {
set value [my LoadOrLiteral $src]
if {$tgttype ne $srctype} {
set value [$b unmaybe $value $name]
}
} else {
set value [my LoadOrLiteral $src]
}
if {refType($tgttype)} {
$b printref $value "extract:"
$b addReference($tgttype) $value
}
my StoreResult $tgt $value
return
}
# TclCompiler:IssueValueInit --
#
# Generate the code for initialising a value from a constant if it is
# not already set by another route. Must only be called from the
# 'compile' method.
#
# Parameters:
# operation -
# The quadcode descriptor for the instruction.
#
# Results:
# none
method IssueValueInit {operation} {
lassign $operation opcode tgt src def
set type [my OperandType $src]
# Types may make this simple.
if {$type eq "NEXIST"} {
set value [my LoadOrLiteral $def]
} elseif {!failType($type)} {
set value [my LoadOrLiteral $src]
} else {
# Nope; do it at run-time.
set test [$b exists [my LoadOrLiteral $src]]
set stype [lrange $type 1 end]
set value [$b select [$b expect $test true] \
[$b unmaybe [my LoadOrLiteral $src]] \
[my LoadTypedLiteral [lindex $def 1] $stype]]
}
set type [my OperandType $tgt]
if {refType($type)} {
$b printref $value "init:"
$b addReference($type) $value
}
my StoreResult $tgt $value
return
}
# TclCompiler:IssueThrowIfNEXIST --
#
# Generate the code for creating an exception if the value given to it
# indicates something that doesn't exist (e.g., that corresponds to an
# unset Tcl variable). Must only be called from the 'compile' method.
#
# Parameters:
# operation -
# The quadcode descriptor for the instruction.
#
# Results:
# LLVM int1 that is true if the target of the branch is to be taken.
method IssueThrowIfNEXIST {operation} {
upvar 1 tgt tgtPC
lassign $operation opcode branchTarget src varname
set name [my LiteralValue $varname]
set msg "can't read \"$name\": no such variable"
set exn [list TCL LOOKUP VARNAME $name]
set type [my OperandType $src]
set tgtPC [lindex $branchTarget 1]
# Types may make this simple.
if {$type eq "NEXIST"} {
set msg [Const $msg STRING]
set exn [Const $exn STRING]
$b initException $exn $msg $errorCode
return [Const 1 bool]
} elseif {!failType($type)} {
return [Const 0 bool]
} else {
# Nope, do it at run-time.
set msg [Const $msg STRING]
set exn [Const $exn STRING]
return [my Unlikely existsOrError [my LoadOrLiteral $src] \
$msg $exn $errorCode]
}
}
# TclCompiler:IssueException --
#
# Generate the code for creating a general exception (e.g., from
# [error], [throw] or [return] with options. Must only be called from
# the 'compile' method.
#
# Parameters:
# operation -
# The quadcode descriptor for the instruction.
#
# Results:
# none
method IssueException {operation} {
upvar 1 errorCode errorCode
set srcs [lassign $operation opcode tgt src]
set src2 [lindex $srcs 0]
set maintype [my ValueTypes $src]
set name [my LocalVarName $tgt]
append opcode ( [my ValueTypes {*}$srcs] )
set value [my LoadOrLiteral $src]
# Check if we can issue more efficient code by understanding the
# literals provided (if everything is non-literal, we can't do much).
if {[llength $srcs] == 3 && literal($src2)} {
catch {
set dlen -1
set s2lit [lindex $src2 1]
set dlen [dict size $s2lit]
}
if {$dlen == 1 && [dict exists $s2lit -errorcode]
&& $maintype eq "STRING"
&& literal([lindex $srcs 1]) && literal([lindex $srcs 2])
&& [lindex $srcs 1 1] == 1 && [lindex $srcs 2 1] == 0} {
# Really a throw
set exn [Const [dict get $s2lit -errorcode] STRING]
$b initException $exn $value $errorCode
my StoreResult $tgt [$b nothing $maintype]
return
}
if {$dlen == 0} {
# Blank options; substitute a NULL
set vals [linsert [lmap s [lrange $srcs 1 end] {
my LoadOrLiteral $s
}] 0 [$b null STRING]]
}
} elseif {[llength $srcs] == 1 && literal($src2)} {
my Warn "need to analyse options: %s" [lindex $src2 1]
}
# No special instruction sequence; pass it all through to the
# lower-level code issuers.
if {![info exist vals]} {
set vals [lmap s $srcs {my LoadOrLiteral $s}]
}
my StoreResult $tgt [$b $opcode {*}$vals $value $maintype \
$errorCode $name]
return
}
# TclCompiler:Unlikely --
#
# Issue a (boolean-returning) instruction and mark it as being expected
# to produce a false.
#
# Parameters:
# args - The words to use when passing to the builder object to issue
# the instruction.
#
# Results:
# The int1 LLVM value reference.
method Unlikely args {
return [$b expect [$b {*}$args] false]
}
# TclCompiler:OperandType --
#
# Get the typecode of a particular operand.
#
# Parameters:
# operand -
# The operand to get the typecode of.
#
# Results:
# The typecode.
method OperandType {operand} {
nameOfType [typeOfOperand $vtypes $operand]
}
# TclCompiler:ValueTypes --
#
# Convert the sequence of arguments (to an opcode) into the type
# signature tuple to use with the name of the method in the Build class
# to enable automatic type widening.
#
# Parameters:
# args... -
# The list of quadcode argument descriptors.
#
# Results:
# The comma-separated type descriptor list.
method ValueTypes {args} {
return [join [lmap val $args {
my OperandType $val
}] ","]
}
# TclCompiler:FuncName --
#
# Get the actual name of a command that might be called, taking into
# account tricky things like the resolution context.
#
# Parameters:
# name - The name of the command to be called.
#
# Results:
# The fully-qualified command name.
method FuncName {name} {
namespace eval $namespace [list namespace which $name]
}
# TclCompiler:LocalVarName --
#
# Get the suggested name for a local variable used in issued code. This
# is based on the name in the source material. Note that coincident
# names are OK; the names are DISTINCT from their identity (and will be
# uniqued by LLVM internally, probably by adding a number to the end).
#
# Parameters:
# desc - The descriptor of the variable concerned.
# suffix (optional) -
# Some extra parts to add to the name to help make it unique.
# Only rarely used, in situations where derived names are
# necessary.
#
# Results:
# The fully-qualified command name.
method LocalVarName {desc {suffix ""}} {
set name [lindex $desc 1]
if {[string is integer $name]} {
set name tmp.$name
}
if {$suffix ne ""} {
append name . $suffix
}
return $name
}
# TclCompiler:LoadOrLiteral --
#
# Generate the code to create a LLVM value reference, given the
# descriptor of what the variable should be.
#
# Parameters:
# desc - The descriptor of the variable or literal concerned.
#
# Results:
# The name.
method LoadOrLiteral {desc} {
if {[info exist variables($desc)]} {
return $variables($desc)
}
lassign $desc kind value
if {$kind ne "literal"} {
return -code error "unsubstitutable argument: $desc"
}
set type [nameOfType [typeOfLiteral $value]]
return [my LoadTypedLiteral $value $type]
}
# TclCompiler:LoadTypedLiteral --
#
# Generate the code to create a LLVM value reference, given the
# descriptor of what the variable should be.
#
# Parameters:
# value - The Tcl value that we are creating a literal for.
# type - The quadcode type that we are going to produce.
#
# Results:
# The name.
#
# Maintainer note:
# DO NOT do reference count management in this function! It makes things
# leak or triggers use-after-free crashes. Leave that to the main
# compiler engine (and the STRING allocator) as that gets it right.
method LoadTypedLiteral {value type} {
if {[lindex $type 0] eq "IMPURE"} {
set sval [my LoadTypedLiteral $value STRING]
set itype [lrange $type 1 end]
set tval [my LoadTypedLiteral $value $itype]
return [$b impure $itype $sval $tval]
} elseif {$type eq "DOUBLE"} {
return [ConstReal [Type $type] $value]
} elseif {$type in {"ZEROONE" "BOOLEAN" "ZEROONE BOOLEAN"}} {
return [Const [expr {$value}] bool]
} elseif {$type in {"INT" "ENTIER"}} {
return [$b int [expr {entier($value)}]]
} elseif {$type in {"STRING" "EMPTY"}} {
set result [Const $value STRING]
$b assume [$b shared $result]
return $result
} else {
return -code error \
"unhandled type for literal \"${value}\": \"$type\""
}
}
# TclCompiler:StoreResult --
#
# Store the result of a (translated) quadcode operation in a variable.
# The variable must have been initialised previously. (It is RECOMMENDED
# that a 'load' from a variable of a suitable type be used, as those are
# trivially unique from one another.)
#
# Parameters:
# desc - The descriptor of the variable that the value will be written
# to.
# value - The LLVM value reference to the value to place in the variable
# named by the 'desc' argument.
# opcode (optional) -
# The quadcode opcode for which we are issuing this store. Only
# currently useful for enabling a different sort of debugging
# behaviour with phi nodes, as those must not be interleaved
# with debugging intrinsics (unlike with other result-producing
# operations).
#
# Results:
# None.
method StoreResult {desc value {opcode ""}} {
if {[lindex $desc 0] eq "literal"} {
return -code error "cannot store into literal; it makes no sense"
}
if {[info exist variables($desc)]} {
set targetType [TypeOf $variables($desc)]
if {$targetType ne [TypeOf $value]} {
my Warn "variable is of type %s and assigned value (to '%s') is %s" \
[PrintTypeToString $targetType] \
$desc [PrintValueToString $value]
}
}
if {[lindex $desc 0] eq "var"} {
if {$opcode eq "phi"} {
upvar 1 phiAnnotations todo
lappend todo [lindex $desc 1] $value
} else {
my AnnotateAssignment [lindex $desc 1] $value
}
}
if {[info exist variables($desc)]} {
if {$targetType ne [TypeOf $value]} {
return -code error [format \
"type mismatch: variable {%s} of type '%s' but was assigned value of type '%s'" \
$desc [PrintTypeToString [TypeOf $variables($desc)]] \
[PrintTypeToString [TypeOf $value]]]
}
ReplaceAllUsesWith $variables($desc) $value
}
set variables($desc) $value
return
}
# TclCompiler:AnnotateAssignment --
#
# Annotate an assignment to a named Tcl variable with debug metadata
# stating as such. Note that this does not guarantee to perform the
# annotation; the debugging info for the variable must have been created
# first.
#
# Parameters:
# name - The name of the Tcl variable, as extracted from a descriptor.
# value - The LLVM value reference to the value that was assigned.
#
# Results:
# None.
#
# Side effects:
# May issue instructions. Do not use between phi nodes.
method AnnotateAssignment {name value} {
if {$value ne "Nothing"} {
[$func module] debug value $value [$func getvardb $name]
}
return
}
# TclCompiler:ReferenceType? --
#
# Test if a particular type code is a reference type or not. Reference
# types need extra care when managing the lifetime of.
#
# Parameters:
# type - The type code to look at.
#
# Results:
# Boolean, true if the type is a reference type.
method ReferenceType? {type} {
if {[string is entier -strict $type]} {
set type [nameOfType $type]
}
foreach piece $type {
if {$piece in {IMPURE DICTITER EMPTY STRING ENTIER}} {
return 1
}
}
return 0
}
# TclCompiler:FailureType? --
#
# Test if a particular type code is a failure type or not. There are
# several different sorts of failure type.
#
# Parameters:
# type - The type code to look at.
#
# Results:
# Boolean, true if the type is a failure type.
method FailureType? {type} {
if {[string is entier -strict $type]} {
set type [nameOfType $type]
}
foreach piece $type {
if {$piece in {FAIL NEXIST}} {
return 1
}
}
return 0
}
# TclCompiler:IsConsumed --
#
# Determine if a (reference) value is consumed by this basic block. A
# value is consumed if there is a 'free' of the value occurs later in
# the block with no other uses before then. If so, this allows us to
# generate more efficient code in some cases.
#
# Parameters:
# var - The variable we are asking about.
# search -
# The PC to start searching from (generally one later than the
# instruction being compiled).
#
# Results:
# The PC at which the 'free' occurs, or 0 if the value isn't consumed
# (there is never a free as the first instruction in a function, so this
# may be used as a boolean).
method IsConsumed {var search} {
while 1 {
switch [lindex $quads $search 0] {
"free" {
if {[lindex $quads $search 2] eq $var} {
return $search
}
}
"jump" - "jumpFalse" - "jumpTrue" - "return" -
"jumpMaybe" - "jumpMaybeNot" - "returnException" {
return 0
}
default {
if {$var in [lindex $quads $search]} {
return 0
}
}
}
incr search
}
}
# TclCompiler:ConvertIndices --
#
# Convert the most common cases of literal end-based indexing into forms
# that can actually be processed by the low-level code issuer.
#
# Parameters:
# valuePosition -
# The position in the argument list that the string that is
# being indexed into is located at.
# lengthOp -
# The operation to use for getting the length of the thing being
# indexed into.
# args -
# The positions that are to be adjusted.
#
# Results:
# The list of arguments to be passed to the low-level opcode method.
method ConvertIndices {valuePosition lengthOp args} {
upvar 1 opcode opcode srcs srcs
set s2 $srcs
set s3 [lmap s $srcs {my LoadOrLiteral $s}]
set worthMapping 1
set INDEX_RE {^(?:\d+|end(?:-\d+))$}
foreach indexPosition $args {
set index [lindex $s2 $indexPosition]
if {!literal($index) || ![regexp $INDEX_RE [lindex $index 1]]} {
set worthMapping 0
break
}
}
if {$worthMapping} {
foreach indexPosition $args {
set index [lindex $s2 $indexPosition 1]
if {$index eq "end"} {
lset s2 $indexPosition "literal 0"
if {![info exist length]} {
set length [$b ${lengthOp}(STRING) [lindex $s3 0]]
}
lset s3 $indexPosition $length
} elseif {[string match "end*" $index]} {
lset s2 $indexPosition "literal 0"
if {![info exist length]} {
set length [$b ${lengthOp}(STRING) [lindex $s3 0]]
}
set delta [list literal [string range $index 3 end]]
lset s3 $indexPosition \
[$b add(INT,INT) $length [my LoadOrLiteral $delta]]
}
}
}
append opcode ( [my ValueTypes {*}$s2] )
return $s3
}
# TclCompiler:LiteralValue --
#
# Extract the value of a quadcode literal, verifying that the value
# actually is a literal.
#
# Parameters:
# qcval - The quadcode value to extract from.
#
# Results:
# The Tcl value inside the quadcode value.
method LiteralValue {qcval} {
lassign $qcval key value
if {$key ne "literal"} {
return -code error "assumption that '$qcval' is literal not met"
}
return $value
}
}
# Class TclInterproceduralCompiler --
#
# This class compiles a single Tcl procedure within the overall
# framework of the tclquadcode type specializer.
#
# Construction Parameters:
# specializer -
# The TclOO handle to the type specializer.
# command -
# The fully-qualified name of the procedure to compile.
# argumentTypes -
# The Tcl list of quadcode typecodes for the arguments to this
# procedure.
#
# Public properties:
# commandName -
# The human-readable name of the function we are compiling/have
# compiled. Note that this is not necessarily the same as the
# name of the function in the code *or* the name of the Tcl
# command that will be replaced by this function.
oo::class create TclInterproceduralCompiler {
superclass TclCompiler
variable quadcode cmd bytecode readableName func
constructor {specializer command argumentTypes} {
next
my ByteCode $command [::tcl::unsupported::getbytecode proc $command]
set info [$specializer makeInstance $command $argumentTypes]
lassign $info rt ats tmap quadcode
my InitTypeInfo $ats $rt $tmap
set ats [lmap t $ats {nameOfType $t}]
set readableName ${cmd}([string map {" " .} [join $ats ,]])
}
# TclInterproceduralCompiler:commandName (property) --
#
# Get the human-readable name of the function we are compiling/have
# compiled. Note that this is not necessarily the same as the name of
# the function in the code *or* the name of the Tcl command that will be
# replaced by this function.
method commandName {} {
return $readableName
}
# TclInterproceduralCompiler:compile --
#
# Generate the body for the function that we are transforming the Tcl
# code into. The function's declaration must have already been
# generated.
#
# Parameters:
# none
#
# Results:
# The LLVM function reference that we have generated. Note that this
# will be an unoptimised function at this stage.
method compile {} {
try {
my Compile $quadcode
} on error {msg opts} {
dict append opts -errorinfo \
"\n (compiling code for \"$cmd\")"
return -options $opts $msg
}
}
# TclInterproceduralCompiler:generateThunk --
#
# Generate the binding into Tcl of the function that we transformed the
# procedure into.
#
# Parameters:
# thunkBuilder -
# The API binding class instance.
#
# Results:
# The function reference (i.e., instance of Function class) for the
# binding function. (Not the bound function, which this class made.)
method generateThunk {thunkBuilder} {
if {[dict exists $bytecode procmeta]} {
$thunkBuilder buildProcedureMetadata $cmd $bytecode \
[dict get $bytecode procmeta]
dict unset bytecode procmeta
}
$thunkBuilder thunk $cmd $bytecode $func
}
# TclInterproceduralCompiler:printTypedQuads --
#
# Print the sequence of typed quadcodes that the type inference engine
# has transformed the procedure into.
#
# Parameters:
# channel (optional) -
# Where to write the message. If not supplied, returns the the
# string that would have been printed instead.
#
# Results:
# The string if a channel is not supplied, otherwise none.
method printTypedQuads {{channel ""}} {
my PrintTypedQuads $channel $quadcode
}
}
# Local Variables:
# mode: tcl
# fill-column: 78
# auto-fill-function: nil
# buffer-file-coding-system: utf-8-unix
# End: