added some support for SEXP type, making a vectorized function

.gitignore

@@ -0,0 +1 @@
+TAGS

NAMESPACE

@@ -23,3 +23,5 @@ export(declareFunction)
 export(insertReturn)
 S3method(insertReturn, "function")
 
+
+export(vectorizeFunction)

R/call.R

@@ -4,7 +4,6 @@ callHandler =
   #
 function(call, env, ir, ..., fun = env$.fun, name = getName(fun))
 {
-
    funName = as.character(call[[1]])
 
    if(funName == "<-")

R/compileSApply.R

@@ -83,6 +83,16 @@ function(call, vecType, returnType, addReturn = TRUE, env = NULL, ir = NULL, ...
 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"))) 
@@ -93,6 +103,8 @@ function(type)
      stop("problem getting R data accessor routine name")
 }
 
+
+# Should  borrow from Rllvm.
 STRSXP = 16L
 LGLSXP = 9L
 REALSXP = 14L
@@ -105,7 +117,7 @@ function(type)
 {
   if(sameType(type, getSEXPType("STR")) || sameType(type, StringType))
      c(STR = STRSXP)
-  else if(sameType(type, getSEXPType("REAL")))
+  else if(sameType(type, getSEXPType("REAL")) || sameType(type, DoubleType))
      c(REAL = REALSXP)
   else if(sameType(type, getSEXPType("LGL")))
      c(LGL = LGLSXP)

R/makeVectorized.R

@@ -9,7 +9,7 @@ vectorizeFunction =
 #
 #  vectorizeFunction(Dnorm, scalar = "Dnorm")
 #
-function(f, fc = NULL, typeInfo, module = as(fc, "Module"), 
+function(f, fc = NULL, typeInfo = NULL, module = as(fc, "Module"), 
          scalarFunName = getName(fc), vectorArgName = names(parms)[1])
 {
   g = f
@@ -19,8 +19,8 @@ function(f, fc = NULL, typeInfo, module = as(fc, "Module"),
       e[seq(4, length = nargs - 1L) ] = lapply(names(parms)[seq(2, length = nargs - 1L)], as.name)
 
   body(g) = e
-  if(length(types)) {
+  if(length(typeInfo)) {
 
   } else
      g	 
-}
+}

tests/dnorm.R

@@ -1,16 +1,38 @@
 library(RLLVMCompile)
 
-f = function(x, mu = 0, sd = 1)
+Dnorm = function(x, mu = 0, sd = 1)
          1/sqrt(2 * pi * sd^2) * exp( - .5*( (x-mu)/sd ) ^2)
 
 x = rnorm(5)
-all(dnorm(x) == f(x))
+all(dnorm(x) == Dnorm(x))
 
-fc = compileFunction(f, DoubleType, list(DoubleType, DoubleType, DoubleType))
+ # Fails on linux with a mismatch of arguments in one of the calls.
+fc = compileFunction(Dnorm, DoubleType, list(DoubleType, DoubleType, DoubleType))
+if(FALSE) {
 fc = compileFunction(f, DoubleType, list(x = DoubleType, DoubleType, DoubleType),
                        vectorize = "x")
-
 fc = compileFunction(f, arrayType(DoubleType), list(arrayType(DoubleType), DoubleType, DoubleType))
+}
+
+mod = as(fc, "Module")
+g = vectorizeFunction(Dnorm, scalar = "Dnorm")
+REALSXPType = getSEXPType("REAL")
+gc = compileFunction(g, REALSXPType, list(REALSXPType, DoubleType, DoubleType), module = mod)
+
+all(.llvm(gc, x, 0, 1) == dnorm(x, 0, 1))
+
+library(compiler)
+Dnormc = cmpfun(Dnorm)
+
+n = 1e5
+x = rnorm(n)
+
+ee = ExecutionEngine(mod)
+tm.1e5 = list(llvm = system.time(replicate(20, .llvm(gc, x, 0, 1, .ee = ee))),
+              bytec = system.time(replicate(20, Dnormc(x))),
+              native = system.time(replicate(20, dnorm(x))),
+              r = system.time(replicate(20, g(x))))
+
 
 #
 # double *fc(double *x, size_t x_length, double mu, double sd)