callRFunction =
function(call, env, ir, ...)
{
funName = as.character(call[[1]])
funTypes = env$.CallableRFunctions[[funName]]
if(funName == ".R") {
if(length(call) > 1)
funTypes = eval(call[[3]])
call = call[[2]]
}
# We have the call to the R function. But we need to match the arguments.
# We have to convert regular objects to R objects. However, when we have a SEXPType
# that hasn't been updated within the routine, we can pass this directly.
# We can generate code to create the call. Alternatively, within the same R session
# we can R_PreserveObject the call and then reuse it at call-time in the compiled code.
# We have to fill in the arguments for each call.
# We want to create the call expression just once, regardless if we pass it from the compiler
# or create it ourselves.
# How do we assign an R object to a global variable in a module.
# We could serialize the call to a byte stream and restore it in the module.
# Use getVariable.
# Need to compile any arguments that are expressions.
# compile(e, env, ir, ...)
# put the current call into the module with name <funName>.call
#
# Potentially, preserve the call by putting it in the environment of the R function that is a proxy for the
# the LLVM routine.
id = sprintf("%s_expression", funName)
llvmAddSymbol(R_GlobalEnv = getNativeSymbolInfo("R_GlobalEnv"))
createGlobalVariable("R_GlobalEnv", env$.module, SEXPType)
#XXX We need to specify the caller. If the caller has given us the ExecutionEngine
# we could set this. Check !is.null(env$.ExecEngine).
callVar = createGlobalVariable(id, env$.module, SEXPType, getNULLPointer(SEXPType))
# compileSetCall(id, sprintf("setCall_%s", id), env$.module)
# Add info to .SetCallFuns to have the top-level compiler generate these routines when it is finished.
env$.SetCallFuns[[ length(env$.SetCallFuns) + 1L]] = createCall = list(var = id,
name = sprintf("setCall_%s", id),
createCallFun = sprintf("create_%s", id),
deserializeCallFun = sprintf("deserialize_%s", id),
call = call)
cc = Function(createCall$createCallFun, SEXPType, list(), module = env$.module)
cc = Function(createCall$deserializeCallFun, SEXPType, list(), module = env$.module)
e = substitute( if( var == NULL ) var <- mk(),
list(var = as.name(createCall$var), mk = as.name(createCall$deserializeCallFun),
msg = sprintf("calling %s\n", createCall$createCallFun)))
env$.remainingExpressions = list(NULL) #XXXX
compile(e, env, ir, ...)
# if(!is.null(env$.ExecEngine) ) {
# env$.module[[id, .ee = env$.ExecEngine]] = call
# }
# Now, generate the code that puts the local variables into the call.
insertLocalValues(call, id, env, ir, ...)
#!!! debug: show the updated expressions.
#compile(substitute(Rf_PrintValue(var), list(var = as.name(id))) , env, ir, ...)
# Then evaluate the call
e = substitute(r_ans <- Rf_eval(callVar, R_GlobalEnv), list(callVar = as.name(id)))
val = compile(e, env, ir, ...)
compile(quote(Rf_protect(r_ans)), env, ir, ...)
# Do we need to protect this return value?
# compile(quote(Rf_protect(r_ans)), env, ir, ...)
# compile(quote(Rf_unprotect_ptr(rans)), env, ir, ...)
# Now get the result and marshall it back
if(sameType(funTypes[[1]], StringType)) {
# memory management.
marshallAns = quote(ans <- strdup(R_CHAR(STRING_ELT(r_ans, 0)))) # XXXX Somebody needs to free this.
} else if(sameType(funTypes[[1]], Int32Type)) {
marshallAns = quote(ans <- Rf_asInteger(r_ans))
} else if(sameType(funTypes[[1]], DoubleType)) {
marshallAns = quote(ans <- Rf_asReal(r_ans))
} else if(sameType(funTypes[[1]], SEXPType)) {
return(val)
} else {
stop("don't know how to handle this type")
}
e = compile(marshallAns, env, ir)
# compile(quote(Rf_PrintValue(r_ans)), env, ir, ...)
compile(quote(Rf_unprotect(1L)), env, ir, ...)
e
}
# Also in createLoop.R. So put into a function.
# But we don't need them and actually introduced a bug since we spelled r_ans as rans in the Rf_eval() later on
# So better to let the type specification work for us.
createCompilerLocalVariable =
function(name, type, env, ir)
{
tmp = createFunctionVariable(type, name, env, ir)
assign(name, tmp, env)
env$.types[[name]] = type
tmp
}
compileSetCall =
#
# This creates a new function/routine in the module
# that allows us to call it from R to set a SEXP type
# that is a call to a global variable that will then be used
# to callback to R from an LLVM-generated routine.
function(varName, funName, module)
{
f = function(tmp) {
R_PreserveObject(tmp)
var = tmp
}
body(f)[[3]][[2]] = as.name(varName)
# Can we compile a new function while currently in the middle of compiling another with a different IRBuilder.
compileFunction(f, VoidType, list(SEXPType), module, name = funName)
}
compileCreateCall =
#
# Do we want to make this a separate routine
#
function(env, ir, call, globalVarName = NA, ...)
{
funName = as.character(call[[1]])
# Rf_protect( ) around the entire thing ?
e = substitute( zz <- Rf_allocVector(LANGSXP, nels) , # LANGSXP
list(nels = length(call)))
compile(e, env, ir, ...)
tmp = substitute(SETCAR(zz, Rf_install(id)), list(id = funName))
compile(tmp, env, ir, ...)
compile(quote(cur <- CDR(zz)), env, ir, ...)
argNames = names(call)
for(i in seq(along = call)[-1]) {
val = if(is.name(call[[i]]))
substitute(Rf_install(x), list(x = as.character(call[[i]])))
else if(is.integer(call[[i]]))
substitute(Rf_ScalarInteger(x), list(x = call[[i]]))
else if(is.numeric(call[[i]]))
substitute(Rf_ScalarReal(x), list(x = call[[i]]))
else if(is.logical(call[[i]]))
substitute(Rf_ScalarLogical(x), list(x = call[[i]]))
else if(is.character(call[[i]]))
substitute(Rf_mkString(x), list(x = call[[i]]))
else {
warning("cannot recreate non-local value in R expression")
quote(Rf_install("<expr>"))
}
tmp = substitute(SETCAR(cur, val), list(val = val))
compile(tmp, env, ir, ...)
if(length(argNames) && argNames[i] != "") {
compile(substitute(SET_TAG(cur, Rf_install(id)), list(id = argNames[i])), env, ir, ...)
}
if(i < length(call))
compile(quote(cur <- CDR(cur)), env, ir, ...)
}
if(!is.na(globalVarName) && globalVarName != "") {
e = substitute( if( var != NULL ) R_ReleaseObject(var), list(var = as.name(globalVarName)))
set = substitute( v <- zz, list(v = as.name(globalVarName)))
env$.remainingExpressions = list(set) #XXX horrible. Needed to get the NextBlock
compile(e, env, ir, ...)
compile(set, env, ir, ...)
}
compile(quote(return(zz)), env, ir, ...) # ir$createRet(ir$createLoad(getVariable()))
# compile(quote({printf("expression: "); Rf_PrintValue(zz)}), env, ir, ...)
}
compileCreateCallRoutine =
#
# Do we need a new compiler?
# Do we want to make this a separate routine
#
function(env, ir, call, name, globalVarName = NA)
{
# The function should have already been declared in callRFunction.
# But here it is as it used to be:
# f = Function(name, VoidType, list(), module = env$.module)
compilerStartFunction(env, ir, name, SEXPType)
compileCreateCall(env, ir, call, globalVarName)
}
createDeserializeCall =
function(env, ir, call, name, globalVarName = NA, ...)
{
compilerStartFunction(env, ir, name, SEXPType)
llvmAddSymbol(getNativeSymbolInfo("R_loadRObjectFromString", "RLLVMCompile"))
# serialize the call to a string
txt = saveRObjectAsString(call)
# create call to the C routine to deserialize this and compile this expression
e = substitute(R_loadRObjectFromString(x), list(x = txt))
v = compile(e, env, ir, ...)
ir$createRet(v)
}
insertLocalValues =
#
# Given the call template, generate the code to insert local variables into
# the
function(call, callVar, env, ir, ...)
{
# For now, only deal with literals, symbols and calls!
# Probably just loop over all of them and determine if they involve local variables.
call = call[-1]
w = sapply(call, function(x) is.name(x) || is.call(x))
if(any(w)) {
# need to CDR() up to the first element. Then insert the value and go to the next one.
# Get the first argument, i.e. skip over the function name/obj.
compile(substitute(el <- CDR(v), list(v = as.name(callVar))), env, ir, ...)
jmp = substitute(el <- CDR(el), list(call = as.name(callVar)))
e = quote(SETCAR(el, val))
for(i in seq(along = w)) {
if(w[i]) {
varName = call[[i]]
usesLocal = usesLocalVariables(call[[i]], env)
if(usesLocal) {
if(is.call(varName)) {
var = compile(substitute(.tmp <- e, list(e = call[[i]])), env, ir, ...)
varName = as.name(".tmp")
} else {
var = getVariable(as.character(varName), env, load = FALSE, searchR = FALSE)
if(!is(var, "Argument"))
var = ir$createLoad(var)
}
ty = Rllvm::getType(var)
v = if(sameType(ty, Int32Type))
substitute(Rf_ScalarInteger(x), list(x = varName))
else if(sameType(ty, DoubleType))
substitute(Rf_ScalarReal(x), list(x = varName))
else if(sameType(ty, StringType))
substitute(Rf_mkString(x), list(x = varName))
else if(sameType(ty, SEXPType))
as.name(varName)
else
stop("don't know how to handle this type yet")
e[[3]] = v
compile(e, env, ir, ...)
} # end of usesLocal
compile(jmp, env, ir, ...)
}
}
}
}
usesLocalVariables =
function(expr, env)
{
f = function() "will be replaced by expr"
body(f) = expr
info = findGlobals(f, FALSE)
localVarNames = c(names(env$.localVarTypes), env$.params@names, names(env$.types))
any(info$variables %in% localVarNames)
}
# NOT USED
isRAtomic =
function(x)
is.logical(x) || is.integer(x) || is.numeric(x) || is.character(x)
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.