# thunk.tcl --
#
# Constructs the interface between the code generated by the compilation
# engine and Tcl. Manages the generation of a function that creates Tcl
# commands for each of the functions we compile. See tclapi.tcl for the
# part of this class that maps Tcl's own API into LLVM.
#
# Copyright (c) 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.
#
#------------------------------------------------------------------------------
# Class ThunkBuilder --
#
# This class constructs the interface between Tcl and the rest of the
# LLVM-generated code.
#
# Construction Parameters:
# module -
# The module that owns this interface.
#
# Public properties:
# None.
oo::class create ThunkBuilder {
superclass BuildSupport
variable m b metathunk metathunkblock metathunkerror metathunkref
variable makingThunks thunkprocmeta
variable 0 1 OK ERROR
variable Tcl_Interp Tcl_UniChar Tcl_Obj Tcl_ObjType mp_int Tcl_RegExp
variable Tcl_ObjCmdType Tcl_ObjCmdPtr
variable Tcl_CmdDeleteProc Tcl_CmdDeletePtr
variable tcl.obj.constant
constructor {module} {
next [set b [$module builder]]
variable obj.constants.pending {}
set m $module
set 0 [set OK [Const 0]]
set 1 [set ERROR [Const 1]]
set makingThunks 0
set thunkprocmeta {}
set Tcl_CmdDeleteProc [Type func{void<-ClientData}]
set Tcl_CmdDeletePtr [Type $Tcl_CmdDeleteProc*]
set Tcl_UniChar [Int16Type]
set Tcl_ObjCmdType [Type func{int<-ClientData,Tcl_Interp*,int,Tcl_Obj**}]
set Tcl_ObjCmdPtr [Type $Tcl_ObjCmdType*]
oo::objdefine $b export Call
my InitTclMathfuncs
set name "[$module name]_Init"
set metathunk [$module function.create $name func{int<-Tcl_Interp*}]
my buildInSection preface {
[$metathunk block "enter"] build-in $b
my variable interp
set interp [$metathunk param 0 "interp"]
}
# ThunkBuilder:fprintf,fflush,printf,exit,stdout,stderr --
#
# Various bits and pieces from the C standard library.
#
# Parameters:
# Various, see C standard library documentation.
#
# Results:
# Various, see C standard library documentation.
my Global fprintf func{int<-void*,char*,...}
my Global fflush func{int<-void*}
my Global printf func{int<-char*,...}
my Global exit func{void<-int}
# Note that these three are bound specially during the loading process
my Global stdin void*
my Global stdout void*
my Global stderr void*
my InitTclAPI $interp
$b @apiFunctions $module [self]
my buildInSection initConstant {
set metathunkblock [$metathunk block createConstants]
$b br $metathunkblock
set metathunkerror [$metathunk block error]
$metathunkblock build $b {
foreach {var str len} ${obj.constants.pending} {
$b Call ${tcl.obj.constant} $var $str $len
}
}
}
}
method buildInSection {id script} {
set line [dict get {
preface 1
API 2 APIvar 3
initConstant 4 commands 5
packageProvide 6
} $id]
$m debug scope "" {
$metathunk setAsCurrentDebuggingScope
$b @location $line
uplevel 1 $script
}
}
# ThunkBuilder:Print --
#
# Write a message to an output stdio channel. More flexible than the
# 'writeline' method.
#
# Parameters:
# msg - The value to write.
# destination (optional) -
# Where to write to. Defaults to stdout but can be usefully
# overridden to "stderr".
# format (optional) -
# The format to use when writing. Defaults to %s\n, which
# behaves the same as the 'writeline' method.
#
# Results:
# None.
method Print {msg {destination stdout} {format "%s\n"}} {
set FILE [my $destination]
set str [$b constString $msg "msg"]
my fprintf $FILE [$b constString $format "format"] $str
my fflush $FILE
return
}
# ThunkBuilder:InstallCommand --
#
# Generate the code to create a Tcl command for a compiled function.
#
# Parameters:
# name - The name of the command to create.
# func - The LLVM value reference to the function that implements the
# command. NOTE that this function has to follow the
# Tcl_ObjCmdProc type signature; this does not bind the output
# of the code generator directly.
#
# Results:
# None.
method InstallCommand {name func} {
my variable interp
my buildInSection commands {
$metathunkblock build-in $b
if {!$makingThunks} {
set metathunkblock [$metathunk block createCommands]
$b br $metathunkblock
set makingThunks 1
$metathunkblock build-in $b
}
set namestr [$b constString $name "name.thunk$name"]
set result [my Tcl_CreateObjCommand $interp $namestr [$func ref] \
{} {}]
if {[dict exists $thunkprocmeta $name]} {
set proc [dict get $thunkprocmeta $name]
$b storeInStruct $proc Proc.cmdPtr $result
}
set metathunkblock [$metathunk block createCommands]
$b condBr [$b nonnull $result] $metathunkblock $metathunkerror
}
return
}
# ThunkBuilder:finalize --
#
# Finish the code building done by the thunk engine. The 'install'
# method SHOULD NOT be called until after this method has been called;
# this method is responsible for ensuring that the initialization
# function has actually been finished and put in a callable state. The
# LLVM optimizer should also not be used on a module with an unfinalized
# initialization function in it.
#
# Parameters:
# None.
#
# Results:
# None.
method finalize {} {
if {[info exist metathunkref]} {
return -code error "the API has already been finalized"
}
my variable interp
my buildInSection packageProvide {
set block [$metathunk block leave]
$metathunkblock build $b {
$b br $block
}
$block build $b {
$b ret [my Tcl_PkgProvideEx $interp \
[$b constString [$m name] "pkg.name"] \
[$b constString "0.0.0.1" "pkg.version"] \
[$b null void*]]
}
$metathunkerror build $b {
$b ret $ERROR
}
}
$metathunk verify
set metathunkref [$metathunk ref]
$b destroy
return
}
# ThunkBuilder:install --
#
# Run the module's initialization function using the execution engine
# configured into the module.
#
# Parameters:
# None.
#
# Results:
# None.
method install {} {
if {![info exist metathunkref]} {
return -code error \
"the API must be finalized before being installed"
}
CallInitialisePackageFunction [$m engine] $metathunkref
}
# ThunkBuilder:Global --
#
# Bind a global variable or function to a method of this class and
# return the value of the global. Variables get bound to a method that
# reads them. Functions get bound to a method that calls them.
#
# Parameters:
# name - The name of the global.
# type - The type of the global (an LLVM type reference). Note that the
# kind of type (i.e., function or not) fundamentally alters what
# this method does in the binding code.
#
# Results:
# The LLVM value reference to the global.
method Global {name type} {
set n $name
set type [Type $type]
if {[GetTypeKind $type] eq "LLVMFunctionTypeKind"} {
set g [$m function.extern $n $type]
set c [CountParamTypes $type]
set v [IsFunctionVarArg $type]
my closure $name args {
# Because these are *much* less nasty than crashes!
if {$v && [llength $args] < $c} {
return -code error "insufficient arguments"
} elseif {!$v && [llength $args] != $c} {
return -code error "wrong number of arguments"
}
for {set i 0} {$i < $c} {incr i} {
set expected [TypeOf [GetParam $g $i]]
set got [TypeOf [lindex $args $i]]
if {$got ne $expected} {
return -code error "type mismatch at argument ${i}:\
expected [PrintTypeToString $expected] but\
got [PrintTypeToString $got]"
}
}
$b call $g $args
}
} else {
set g [$m global.get $n $type]
my closure $name {} {
$b load $g
}
}
return $g
}
# ThunkBuilder:thunk --
#
# Generate the Tcl binding thunk function for a function generated by
# the code generator.
#
# Parameters:
# name - The (fully-qualified) name of the Tcl command to generate.
# bytecode -
# The bytecode description dictionary that describes the
# original command. This is an augmented output of the
# [tcl::unsupported::getbytecode] command.
# func - The TclOO handle to the function we are binding to.
#
# Results:
# The function object for the wrapping function.
method thunk {name bytecode func} {
set thunk [$m function.create cmd.thunk$name $Tcl_ObjCmdType]
$thunk setAsCurrentDebuggingScope
set idx -1
set block [$thunk block]
$block build-in $b
$b @location 1
foreach paramName {clientData interp argc argv} {
set $paramName [$thunk param [incr idx] $paramName]
}
lassign [dict get $bytecode signature] restype argtypes
set defaults [dict get $bytecode argumentDefaults]
my CheckArgcInRange $name $interp $argc $argv $defaults
$b @location 2
set realargs {}
set idx 0
foreach arginfo $defaults {
lassign $arginfo argName argDefaulted argDefault
set index [Const [incr idx]]
if {$argDefaulted} {
set defval [my obj.constant $argDefault]
set val [$b call ${thunk.arg.default} \
[list $index $argc $argv $defval]]
} else {
set val [$b dereference $argv $idx]
}
SetValueName $val $argName
$b assume [$b gt [$b refCount $val] [Const 0]]
lappend realargs $val
}
$b @location 3
set value [$b call [$func ref] $realargs "value"]
SetTailCall $value 0
$b @location 4
my MapResultToTcl $interp $value $restype
$b @loc {}
$thunk verify
my InstallCommand $name $thunk
return $thunk
}
# ThunkBuilder:CheckArgcInRange --
#
# Generate code to test whether the argument count to a command
# implementation matches that which is required for calling the
# function.
#
# Parameters:
# name - The (fully-qualified) name of the generated function and the
# command that this function will represent.
# interp -
# The LLVM value reference to the Tcl_Interp*.
# argc - The LLVM value reference to the actual argument count.
# argv - The LLVM value reference to the actual array of arguments.
# argDefaults -
# The description of what default arguments are expected. A Tcl
# list of descriptors for each argument.
#
# Results:
# None.
method CheckArgcInRange {name interp argc argv argDefaults} {
upvar 1 thunk thunk
# Compute how many arguments we expect, including 1 for cmd name
set minargc [set maxargc 1]
foreach argInfo $argDefaults {
incr maxargc
incr minargc [expr {[lindex $argInfo 1] == 0}]
}
# Test if we've got the right number of arguments
set newblock [$thunk block]
set wrongargs [$thunk block "wrongNumArgs"]
$b condBr [$b lt $argc [Const $minargc]] \
$wrongargs $newblock
$newblock build $b {
set newblock [$thunk block]
$b condBr [$b gt $argc [Const $maxargc]] \
$wrongargs $newblock
}
# Too few or too many arguments.
# Generate the "wrong # args" message and return TCL_ERROR
$wrongargs build $b {
set argnamelist {}
set argnames [$b constString [lmap argInfo $argDefaults {
lassign $argInfo argName argDefaulted
lappend argnamelist $argName
set mark [expr {$argDefaulted ? "?" : ""}]
string cat $mark $argName $mark
}] wrongargs_[join $argnamelist _]]
my Tcl_WrongNumArgs $interp $1 $argv $argnames
$b ret $ERROR
}
# Ready things for the next thing in the main instruction stream
$newblock build-in $b
return
}
# ThunkBuilder:MapResultToTcl --
#
# Generate code to create a Tcl value that represents the output of a
# function.
#
# Parameters:
# interp -
# The LLVM value reference to the Tcl_Interp*.
# result -
# The LLVM value reference to the result of the wrapped
# function.
# resultType -
# The human-readable type descriptor for the result of the
# wrapped function. Note that this cannot be deduced from the
# value itself; some Tcl logical types may be convergently
# mapped at the LLVM level.
#
# Results:
# None.
method MapResultToTcl {interp result resultType} {
upvar 1 thunk thunk
# This only happens when all paths are failing paths
if {$resultType in {"VOID FAIL" FAIL}} {
$b ret $ERROR
return
}
set isFailType 0
if {[string match "* FAIL" $resultType]} {
set isFailType 1
set resultType [string range $resultType 0 end-5]
} elseif {[string match "FAIL *" $resultType]} {
set isFailType 1
set resultType [string range $resultType 5 end]
}
if {$isFailType} {
# If a failure happened, the error message will have already been
# set by the opcode that generated it.
set isFail [$thunk block]
set next [$thunk block]
$b condBr [$b maybe $result] $isFail $next
$isFail build $b {
$b ret $ERROR
}
$next build-in $b
set result [$b unmaybe $result]
}
if {[regexp "^IMPURE (.*)" $resultType]} {
set result [$b impure.string $result]
SetValueName $result @result
set resultType STRING
}
upvar 0 thunk.result.$resultType thunkResultMapper
if {![info exist thunkResultMapper]} {
error "unhandled result type: $resultType"
}
$b call $thunkResultMapper [list $interp $result]
if {[info exists ::env(TQC_PRINT_REFERENCE_MANAGEMENT)]} {
$b printref [my Tcl_GetObjResult $interp] "result:"
}
$b ret $OK
return
}
method buildProcedureMetadata {cmd bytecode storage} {
my variable interp
my buildInSection commands {
$metathunkblock build-in $b
if {!$makingThunks} {
set metathunkblock [$metathunk block createCommands]
$b br $metathunkblock
set makingThunks 1
$metathunkblock build-in $b
}
set proc [my cknew Proc "procmeta"]
$b storeInStruct $proc Proc.iPtr [$b cast(ptr) $interp void]
$b storeInStruct $proc Proc.refCount [Const 1]
$b storeInStruct $proc Proc.bodyPtr [$b null STRING]; # FIXME
$b storeInStruct $proc Proc.numArgs [Const 0]; # FIXME
$b storeInStruct $proc Proc.numCompiledLocals [Const 0]; # FIXME
set ncl [$b null CompiledLocal*]
$b storeInStruct $proc Proc.firstLocalPtr $ncl; # FIXME
$b storeInStruct $proc Proc.lastLocalPtr $ncl; # FIXME
my Warn "Procedure metadata for $cmd not complete"; # FIXME
$b store $proc $storage
dict set thunkprocmeta $cmd $proc
}
}
}
# Local Variables:
# mode: tcl
# fill-column: 78
# auto-fill-function: nil
# buffer-file-coding-system: utf-8-unix
# End: