105 lines
2.4 KiB
R
105 lines
2.4 KiB
R
|
library(compiler)
|
||
|
|
|
||
|
|
options(keep.source=TRUE)
|
||
|
|
|
||
|
|
## very minimal
|
||
|
|
x <- 2
|
||
|
|
stopifnot(eval(compile(quote(x + 1))) == 3)
|
||
|
|
|
||
|
|
## simple code generation
|
||
|
|
checkCode <- function(expr, code, optimize = 2) {
|
||
|
|
v <- compile(expr, options = list(optimize = optimize))
|
||
|
|
d <- .Internal(disassemble(v))[[2]][-1]
|
||
|
|
dd <- as.integer(eval(substitute(code), getNamespace("compiler")))
|
||
|
|
identical(d, dd)
|
||
|
|
}
|
||
|
|
x <- 2
|
||
|
|
stopifnot(checkCode(quote(x + 1),
|
||
|
|
c(GETVAR.OP, 1L,
|
||
|
|
LDCONST.OP, 2L,
|
||
|
|
ADD.OP, 0L,
|
||
|
|
RETURN.OP)))
|
||
|
|
f <- function(x) x
|
||
|
|
checkCode(quote({f(1); f(2)}),
|
||
|
|
c(GETFUN.OP, 1L,
|
||
|
|
PUSHCONSTARG.OP, 3L,
|
||
|
|
CALL.OP, 4L,
|
||
|
|
POP.OP,
|
||
|
|
GETFUN.OP, 1L,
|
||
|
|
PUSHCONSTARG.OP, 6L,
|
||
|
|
CALL.OP, 7L,
|
||
|
|
RETURN.OP))
|
||
|
|
|
||
|
|
|
||
|
|
## names and ... args
|
||
|
|
f <- function(...) list(...)
|
||
|
|
stopifnot(identical(f(1, 2), cmpfun(f)(1, 2)))
|
||
|
|
|
||
|
|
f <- function(...) list(x = ...)
|
||
|
|
stopifnot(identical(f(1, 2), cmpfun(f)(1, 2)))
|
||
|
|
|
||
|
|
|
||
|
|
## substitute and argument constant folding
|
||
|
|
f <- function(x) substitute(x)
|
||
|
|
g <- function() f(1 + 2)
|
||
|
|
v1 <- g()
|
||
|
|
f <- cmpfun(f)
|
||
|
|
g <- cmpfun(g)
|
||
|
|
v2 <- g()
|
||
|
|
stopifnot(identical(v1, v2))
|
||
|
|
|
||
|
|
|
||
|
|
## simple loops
|
||
|
|
sr <- function(x) {
|
||
|
|
n <- length(x)
|
||
|
|
i <- 1
|
||
|
|
s <- 0
|
||
|
|
repeat {
|
||
|
|
if (i > n) break
|
||
|
|
s <- s + x[i]
|
||
|
|
i <- i + 1
|
||
|
|
}
|
||
|
|
s
|
||
|
|
}
|
||
|
|
sw <- function(x) {
|
||
|
|
n <- length(x)
|
||
|
|
i <- 1
|
||
|
|
s <- 0
|
||
|
|
while (i <= n) {
|
||
|
|
s <- s + x[i]
|
||
|
|
i <- i + 1
|
||
|
|
}
|
||
|
|
s
|
||
|
|
}
|
||
|
|
sf <- function(x) {
|
||
|
|
s <- 0
|
||
|
|
for (y in x)
|
||
|
|
s <- s + y
|
||
|
|
s
|
||
|
|
}
|
||
|
|
src <- cmpfun(sr)
|
||
|
|
swc <- cmpfun(sw)
|
||
|
|
sfc <- cmpfun(sf)
|
||
|
|
x <- 1 : 5
|
||
|
|
stopifnot(src(x) == sr(x))
|
||
|
|
stopifnot(swc(x) == sw(x))
|
||
|
|
stopifnot(sfc(x) == sf(x))
|
||
|
|
|
||
|
|
|
||
|
|
## Check that the handlers have been associated with the correct package
|
||
|
|
h <- ls(compiler:::inlineHandlers, all.names = TRUE)
|
||
|
|
p <- sub("package:", "", sapply(h, find))
|
||
|
|
pp <- sapply(h, function(n) get(n, compiler:::inlineHandlers)$package)
|
||
|
|
stopifnot(identical(p, pp))
|
||
|
|
|
||
|
|
|
||
|
|
## Check assumption about simple .Internals
|
||
|
|
## These are .External calls now.
|
||
|
|
## stopifnot(all(sapply(compiler:::safeStatsInternals,
|
||
|
|
## function(f)
|
||
|
|
## compiler:::is.simpleInternal(get(f, "package:stats")))))
|
||
|
|
|
||
|
|
stopifnot(all(sapply(compiler:::safeBaseInternals,
|
||
|
|
function(f)
|
||
|
|
compiler:::is.simpleInternal(get(f, "package:base")))))
|