assignToSEXPElement =
function(call, compiledValue, env, ir, type = getElementAssignmentContainerType(call, env), ...)
{
if(is(type, "VECSXPType")) {
e = quote(SET_VECTOR_ELT(x, i, val))
e[[2]] = call[[2]]
e[[3]] = subtractOne(call[[3]])
e[[4]] = compiledValue
compile(e, env, ir, ...)
return(NULL)
stop("not completed yet")
}
if(is(type, "STRSXPType")) {
r = "SET_STRING_ELT"
findFun(r, env) # registers it with the module if necessary.
# we want to modify x[i] = val to SET_STRING_ELT(x, i, val)
# Do we also need to add the mkChar(). Depends on what the type is of the RHS,
# i.e. compiledValue. We may need more information here than we have, i.e. args[[2]] from the caller of this function.
# tmp = compile(compiledValue, env, ir)
# getType(tmp)
ty = getDataType(compiledValue, env)
if(is(ty, "STRSXPType")) {
findFun("STRING_ELT", env)
compiledValue = substitute(STRING_ELT(x, 0L), list(x = compiledValue))
} else if(sameType(ty, StringType)) {
findFun("Rf_mkChar", env)
compiledValue = substitute(Rf_mkChar(x), list(x = compiledValue))
} else
stop("what type should this be for putting into a STRSXP?")
e = substitute(SET_STRING_ELT(x, i, val),
list(x = call[[2]], i = subtractOne(call[[3]]), val = compiledValue))
compile(e, env, ir)
return(NULL)
} # STRING
createSEXPGEP(call, env, ir, ..., type = type)
}
createSEXPGEP =
function(call, env, ir, ..., type = NULL)
{
# check if is name and not call/expressions such as foo()
if(!is.name(call[[2]]))
stop("code doesn't handle this yet")
varName = as.character(call[[2]])
# if we have a dimensioned object, then, for now, we find how to access
# the elements (e.g. REAL, INTEGER) in a different way.
dimensioned = FALSE
if(length(call) > 2 && varName %in% names(env$.dimensionedTypes)) {
dimType = env$.dimensionedTypes[[varName]]
r = getSEXPTypeElementAccessor(dimType@elType, env)
dimensioned = TRUE
} else if(!is.null(type)) { #XXX FIX - need to have a plan if type = NULL.
r = getSEXPTypeElementAccessor(type, env)
}
fn = env$declFunction(r)
# For data frames, we have to do things differently
# So get the variable and then call REAL(), INTEGER(), or whatever on it
# so that ptr is the collection of elements.
var = getVariable(varName, env, ir)
ptr = ir$createCall(fn, var)
# Now compute the index of the element - not elements.
# THIS IS NOT VECTORIZED but SCALAR
isVector = length(call) > 3 && any(sapply(call[-(1:2)], `==`, ""))
idx = compileMatrixOffset(call, env, ir, ..., asSEXT = TRUE) # !isVector)
gep = ir$createGEP(ptr, idx)
return(gep)
#
# rest ignored
##########################################
# call INTEGER(call[[1]]), etc.
e = substitute(.tmp <- r(x), list(r = as.name(r), x = call[[2]]))
compile(e, env, ir, ...)
# now have the original call refer to .tmp
call[[2]] = e[[2]]
call
}
compileMatrixOffset =
function(call, env, ir, ..., asSEXT = TRUE)
{
call[-(1:2)] = lapply(call[-(1:2)], function(x) if(is.numeric(x) && x == as.integer(x)) as.integer(x) else x)
if(length(call) > 3 && ! ( is.name(call[[4]]) && as.character(call[[4]]) == ""))
i = createMultiDimGEPIndex(call, env, ir, ...)
else
i = compile(subtractOne(call[[3]]), env, ir)
if(!asSEXT) # don't convert to a SEXT (64 bit integer). We want the offset for STRING_ELT in multiSubset.R
return(i)
idx = ir$createSExt(i, 64L)
}
getSEXPTypeElementAccessor =
function(type, env)
{
if(is(type, "INTSXPType") || is(type, "LGLSXP") || sameType(type, Int32Type) )
"INTEGER"
else if(is(type, "REALSXPType") || sameType(type, DoubleType) ) # This DoubleType is for when we are dealing with a matrix and have the element type.
'REAL'
else if(is(type, "STRSXPType") || sameType(type, StringType)) {
browser()
'SET_STRING_ELT(%s, %s)'
} else
stop("not done yet")
}
isSEXPType =
function(x)
is(x, "SEXPType")
# Should borrow from Rllvm.
STRSXP = 16L
LGLSXP = 9L
REALSXP = 14L
INTSXP = 13L
CPLXSXP = 15L
ANYSXP = 18L
CHARSXP = 9L
LANGSXP = 6L
SYMSXP = 1L
VECSXP = 19L
S4SXP = 25L
RAWSXP = 24L
EXPTRSXP = 22L
EXPRSXP = 20L
ENVSXP = 4L
getSEXPTypeNumByConstructorName =
function(fun)
{
switch(fun,
numeric = REALSXP,
integer = INTSXP,
logical = LGLSXP,
character = STRSXP,
# list = VECSXP,
stop("unrecognized function to create an R vector"))
}
getSEXPTypeNum =
function(type)
{
# if(class(type) == "Type") # generic
#return(c(ANY = ANYSXP))
# return(c(VEC = VECSXP))
ans = if(is(type, "LGLSXPType") || sameType(type, Int1Type)) #XXX Int1Type is not a class
c(LGL = LGLSXP)
else if(is(type, "INTSXPType") || sameType(type, Int32Type))
c(INT = INTSXP)
else if(is(type, "REALSXPType") || sameType(type, DoubleType))
c(REAL = REALSXP)
else if(is(type, "STRSXPType") || sameType(type, StringType))
c(STR = STRSXP)
else
c(VEC = VECSXP)
# stop("don't know what SEXP type corresponds to this type")
return(ans)
if(FALSE) {
# For old sytem in Rllvm.
if(sameType(type, getSEXPType("STR")) || sameType(type, StringType))
c(STR = STRSXP)
else if(sameType(type, getSEXPType("REAL")) || sameType(type, DoubleType))
c(REAL = REALSXP)
else if(sameType(type, getSEXPType("LGL")))
c(LGL = LGLSXP)
else if(sameType(type, getSEXPType("INT")) || sameType(type, Int32Type))
c(INT = INTSXP)
else
stop("don't know what SEXP type corresponds to this type")
}
}
getSEXPDataAccessor =
function(type)
{
if(is(type, "SEXPType"))
return(switch(class(type),
REALSXPType = "REAL",
INTSXPType = "INTEGER",
LGLSXPType = "LOGICAL",
stop("no accessor for any other type")))
else
stop("cannot determine type of SEXP")
# the following doesn't make sense anymore as we use the same pointer for all the types and only distinguish the SEXPs by the R class.
if(sameType(type, getSEXPType("INT")))
"INTEGER"
else if(sameType(type, getSEXPType("LGL")))
"INTEGER"
else if(sameType(type, getSEXPType("REAL")))
"REAL"
else
stop("problem getting R data accessor routine name")
}
createMultiDimGEPIndex =
function(call, env, ir, ...)
{
# dealing with a matrix for now. Basically,
# we have something of the form x[i, j], and i and j could be expressions.
# We calculate the number of rows in x and then multiply that by j and add i
# using zero-based calculations for i and j.
#
# We also eliminate unnecessary computations if we know at compile time that they are not necesary, e.g.
# if 1st column, don't need number of rows, if first row, don't need to add row offset.
call[3:4] = sapply(call[3:4], function(x) if(is.numeric(x)) as.integer(x) else x)
ee = substitute( (j - 1L) * Rf_nrows(x) + (i - 1L), list(i = call[[3]], j = call[[4]], x = call[[2]] ))
# see if we know this is the first column and if so, we don't need the number of rows.
if(is.numeric(call[[4]]) && call[[4]] == 1L)
ee = ee[[3]]
else if(is.numeric(call[[3]]) && call[[3]] == 1L)
ee = ee[[2]]
if(call[[3]] == "")
ee = ee[[2]]
compile(ee, env, ir, ...)
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.