Tierney 氏の R バイトコンパイラー
をテンプレートにして作成
[
トップ
] [
新規
|
一覧
|
検索
|
最終更新
|
ヘルプ
]
開始行:
COLOR(blue){SIZE(20){L. Tierney 氏の R バイトコンパイラー...
「なんでも掲示板」記事より転載
以前から噂になっている R のバイトコンパイラーですが、すで...
ソース URL は [[ここだよ:http://www.stat.uiowa.edu/~luke/...
いつものいつもの使い方：
(1) パッケージ compiler_0.1-3.tar.gz を通常のようにイン...
(2) R から library(compiler) でロード。詳細説明は ?compi...
(3) 適当な関数 foo をバイトコンパイル foo.c <- cmpfun(fo...
foo のバイトコンパイル版 foo.c (名前は任意) ができる。
(4) foo.c の実際の定義は disassemble(foo.c) で得られる。
(5) 関数定義ファイル infile をバイトコンパイルしたものを...
かきだす： cmpfile(infile, outfile)
(6) バイトコンパイル済みファイル file を読み込むには
loadcmp(file)
ソースコードに附属の例を実行してみました。それなりに早く...
> source("cmp.R")
> # old R version of lapply
> la1 <- function(X, FUN, ...) {
+ FUN <- match.fun(FUN)
+ if (!is.list(X))
+ X <- as.list(X)
+ rval <- vector("list", length(X))
+ for(i in seq(along = X))
+ rval[i] <- list(FUN(X[[i]], ...))
+ names(rval) <- names(X) # keep `name...
+ return(rval)
+ }
> # a small variation
> la2 <- function(X, FUN, ...) {
+ FUN <- match.fun(FUN)
+ if (!is.list(X))
+ X <- as.list(X)
+ rval <- vector("list", length(X))
+ for(i in seq(along = X)) {
+ v <- FUN(X[[i]], ...)
+ if (is.null(v)) rval[i] <- list(v)
+ else rval[[i]] <- v
+ }
+ names(rval) <- names(X) # keep `name...
+ return(rval)
+ }
> # Compiled versions
> la1c <- cmpfun(la1) # la1 をバイ...
Note: local functions used: FUN
> la2c <- cmpfun(la2) # la2 をバイ...
Note: local functions used: FUN
> # some timings
> x<-1:10
> y<-1:100
> system.time(for (i in 1:10000) lapply(x, is.null))
[1] 7.13 0.00 7.12 0.00 0.00
> system.time(for (i in 1:10000) la1(x, is.null))
[1] 13.68 0.01 13.68 0.00 0.00
> system.time(for (i in 1:10000) la1c(x, is.null)) # 1....
[1] 8.79 0.00 8.79 0.00 0.00
> system.time(for (i in 1:10000) la2(x, is.null))
[1] 13.89 0.00 13.89 0.00 0.00
> system.time(for (i in 1:10000) la2c(x, is.null)) # 1....
[1] 8.75 0.00 8.75 0.00 0.00
> system.time(for (i in 1:1000) lapply(y, is.null))
[1] 0.93 0.00 0.93 0.00 0.00
> system.time(for (i in 1:1000) la1(y, is.null))
[1] 5.57 0.00 5.58 0.00 0.00
> system.time(for (i in 1:1000) la1c(y, is.null)) # 4....
[1] 1.22 0.00 1.23 0.00 0.00
> system.time(for (i in 1:1000) la2(y, is.null))
[1] 5.72 0.00 5.71 0.00 0.00
> system.time(for (i in 1:1000) la2c(y, is.null)) # 4....
[1] 1.21 0.00 1.21 0.00 0.00
ちなみにコンパイル済みのコードは次のようになります。実体...
> la1c
function (X, FUN, ...)
{
FUN <- match.fun(FUN)
if (!is.list(X))
X <- as.list(X)
rval <- vector("list", length(X))
for (i in seq(along = X)) rval[i] <- list(FUN(X[[i]]...
names(rval) <- names(X)
return(rval)
}
<bytecode: 0x8b84878>
「データサイエンス入門」中の qiuck 関数で検査。必ずしもい...
> qiuckc <- cmpfun(quick)
> set.seed(1123); system.time(x <- quick(runif(10000)))
[1] 3.92 0.00 3.92 0.00 0.00
> set.seed(1123); system.time(x <- quickc(runif(10000)))
[1] 3.91 0.00 3.92 0.00 0.00 ...
> set.seed(1123); system.time(x <- quick(runif(100000)))
[1] 180.98 43.33 229.42 0.00 0.00
> set.seed(1123); system.time(x <- quickc(runif(100000)))
[1] 163.52 29.56 193.31 0.00 0.00 ...
disassemble(la1c)で覗けば, パース(構文解析)後のデータにな...
なるほど、かなり意味不明のコードに変わっていますね。構文...
> disassemble(la1c)
list(.Code, list(4, GETSYMFUN.OP, 1, MAKEPROM.OP, 2, CAL...
3, SETVAR.OP, 4, POP.OP, GETBUILTIN.OP, 5, GETVAR.OP,...
PUSHARG.OP, CALLBUILTIN.OP, 7, NOT.OP, BRIFNOT.OP, 30...
8, MAKEPROM.OP, 9, CALL.OP, 10, SETVAR.OP, 6, GOTO.OP...
LDNULL.OP, POP.OP, GETINTLBUILTIN.OP, 11, PUSHCONSTAR...
12, GETBUILTIN.OP, 13, GETVAR.OP, 6, PUSHARG.OP, CALL...
14, PUSHARG.OP, CALLBUILTIN.OP, 15, SETVAR.OP, 16, PO...
GETSYMFUN.OP, 17, MAKEPROM.OP, 18, SETTAG.OP, 19, CAL...
20, STARTFOR.OP, 21, 93, GETBUILTIN.OP, 22, GETFUN.OP...
MAKEPROM.OP, 23, DODOTS.OP, CALL.OP, 24, PUSHARG.OP, ...
25, STARTASSIGN.OP, 16, 26, GETVAR.OP, 16, STARTSUBAS...
27, 89, GETVAR.OP, 21, PUSHARG.OP, GETVAR.OP, 26, PUS...
SETTAG.OP, 28, DFLTSUBASSIGN.OP, ENDASSIGN.OP, 16, 26...
STEPFOR.OP, 60, ENDFOR.OP, POP.OP, GETSYMFUN.OP, 29, ...
30, CALL.OP, 31, STARTASSIGN.OP, 16, 26, GETSYMFUN.OP...
MAKEPROM.OP, 33, MAKEPROM.OP, 34, SETTAG.OP, 28, CALL...
35, ENDASSIGN.OP, 16, 26, POP.OP, CALLSPECIAL.OP, 36,...
list({
FUN <- match.fun(FUN)
if (!is.list(X))
X <- as.list(X)
rval <- vector("list", length(X))
for (i in seq(along = X)) rval[i] <- list(FUN(X[[...
...))
names(rval) <- names(X)
return(rval)
}, match.fun, list(.Code, list(4, GETVAR.OP, 0, RETUR...
list(FUN)), match.fun(FUN), FUN, is.list, X, is.l...
as.list, list(.Code, list(4, GETVAR.OP, 0, RETURN...
list(X)), as.list(X), vector, "list", length,...
vector("list", length(X)), rval, seq, list(.Code,...
4, GETVAR.OP, 0, RETURN.OP), list(X)), along,...
i, list, list(.Code, list(4, GETVAR.OP, 1, STARTS...
2, 10, GETVAR.OP, 3, PUSHARG.OP, DFLTSUBSET2....
RETURN.OP), list(X[[i]], X, X[[i]], i)), FUN(...
...), list(FUN(X[[i]], ...)), `*ctmp*`, "[<-"...
i, value = `*ctmp*`), value, names, list(.Cod...
4, GETVAR.OP, 0, RETURN.OP), list(X)), names(...
`names<-`, list(.Code, list(4, GETVAR.OP, 0, RETU...
list(rval)), list(.Code, list(4, GETVAR.OP, 0...
list(`*ctmp*`)), "names<-"(rval, value = `*ct...
return(rval)))
R最適化Tips 中のトランプシミュレーションプログラム test4 ...
> test44 <- function (repl) {
x <- matrixc(0, nrow = 10, ncol=repl)
a <- repc(0:3,13)
for (i in 1:repl) x[,i] <- samplec(a, 10)
y <- matrixc(x, nrow=5)
z <- y - matrixc(y[1,], nrow=5, ncol=2*re...
w <- matrix(colSumsc(abs(z)), nrow=2)
pass <- sumc(w[1,]*w[2,]==0)
pass/repl
}
> test44c <- cmpfun(test44) # 本体もバ...
> set.seed(1111); system.time(test4(10000)) # オリジナ...
[1] 1.11 0.01 1.11 0.00 0.00
> set.seed(1111); system.time(test44c(10000)) # バイト...
[1] 0.58 0.01 0.59 0.00 0.00
> set.seed(1111); system.time(test4(100000)) # オリジ...
[1] 10.66 0.08 10.74 0.00 0.00
> set.seed(1111); system.time(test44c(100000)) # バイト...
[1] 5.71 0.07 5.79 0.00 0.00
しつっこく実験。不思議なことに気づきました。中で使うシス...
> gc(); set.seed(1111); system.time(test4(10000)) # オ...
[1] 1.07 0.02 1.09 0.00 0.00
> gc(); set.seed(1111); system.time(test4c(10000)) # そ...
[1] 0.61 0.01 0.62 0.00 0.00
> gc(); set.seed(1111); system.time(test44(10000)) # 中...
[1] 1.02 0.00 1.02 0.00 0.00
> gc(); set.seed(1111); system.time(test44c(10000)) # そ...
[1] 0.57 0.00 0.57 0.00 0.00
- 2.13.0 のパッケージに含まれていますね。３倍速になるよう...
#comment
終了行:
COLOR(blue){SIZE(20){L. Tierney 氏の R バイトコンパイラー...
「なんでも掲示板」記事より転載
以前から噂になっている R のバイトコンパイラーですが、すで...
ソース URL は [[ここだよ:http://www.stat.uiowa.edu/~luke/...
いつものいつもの使い方：
(1) パッケージ compiler_0.1-3.tar.gz を通常のようにイン...
(2) R から library(compiler) でロード。詳細説明は ?compi...
(3) 適当な関数 foo をバイトコンパイル foo.c <- cmpfun(fo...
foo のバイトコンパイル版 foo.c (名前は任意) ができる。
(4) foo.c の実際の定義は disassemble(foo.c) で得られる。
(5) 関数定義ファイル infile をバイトコンパイルしたものを...
かきだす： cmpfile(infile, outfile)
(6) バイトコンパイル済みファイル file を読み込むには
loadcmp(file)
ソースコードに附属の例を実行してみました。それなりに早く...
> source("cmp.R")
> # old R version of lapply
> la1 <- function(X, FUN, ...) {
+ FUN <- match.fun(FUN)
+ if (!is.list(X))
+ X <- as.list(X)
+ rval <- vector("list", length(X))
+ for(i in seq(along = X))
+ rval[i] <- list(FUN(X[[i]], ...))
+ names(rval) <- names(X) # keep `name...
+ return(rval)
+ }
> # a small variation
> la2 <- function(X, FUN, ...) {
+ FUN <- match.fun(FUN)
+ if (!is.list(X))
+ X <- as.list(X)
+ rval <- vector("list", length(X))
+ for(i in seq(along = X)) {
+ v <- FUN(X[[i]], ...)
+ if (is.null(v)) rval[i] <- list(v)
+ else rval[[i]] <- v
+ }
+ names(rval) <- names(X) # keep `name...
+ return(rval)
+ }
> # Compiled versions
> la1c <- cmpfun(la1) # la1 をバイ...
Note: local functions used: FUN
> la2c <- cmpfun(la2) # la2 をバイ...
Note: local functions used: FUN
> # some timings
> x<-1:10
> y<-1:100
> system.time(for (i in 1:10000) lapply(x, is.null))
[1] 7.13 0.00 7.12 0.00 0.00
> system.time(for (i in 1:10000) la1(x, is.null))
[1] 13.68 0.01 13.68 0.00 0.00
> system.time(for (i in 1:10000) la1c(x, is.null)) # 1....
[1] 8.79 0.00 8.79 0.00 0.00
> system.time(for (i in 1:10000) la2(x, is.null))
[1] 13.89 0.00 13.89 0.00 0.00
> system.time(for (i in 1:10000) la2c(x, is.null)) # 1....
[1] 8.75 0.00 8.75 0.00 0.00
> system.time(for (i in 1:1000) lapply(y, is.null))
[1] 0.93 0.00 0.93 0.00 0.00
> system.time(for (i in 1:1000) la1(y, is.null))
[1] 5.57 0.00 5.58 0.00 0.00
> system.time(for (i in 1:1000) la1c(y, is.null)) # 4....
[1] 1.22 0.00 1.23 0.00 0.00
> system.time(for (i in 1:1000) la2(y, is.null))
[1] 5.72 0.00 5.71 0.00 0.00
> system.time(for (i in 1:1000) la2c(y, is.null)) # 4....
[1] 1.21 0.00 1.21 0.00 0.00
ちなみにコンパイル済みのコードは次のようになります。実体...
> la1c
function (X, FUN, ...)
{
FUN <- match.fun(FUN)
if (!is.list(X))
X <- as.list(X)
rval <- vector("list", length(X))
for (i in seq(along = X)) rval[i] <- list(FUN(X[[i]]...
names(rval) <- names(X)
return(rval)
}
<bytecode: 0x8b84878>
「データサイエンス入門」中の qiuck 関数で検査。必ずしもい...
> qiuckc <- cmpfun(quick)
> set.seed(1123); system.time(x <- quick(runif(10000)))
[1] 3.92 0.00 3.92 0.00 0.00
> set.seed(1123); system.time(x <- quickc(runif(10000)))
[1] 3.91 0.00 3.92 0.00 0.00 ...
> set.seed(1123); system.time(x <- quick(runif(100000)))
[1] 180.98 43.33 229.42 0.00 0.00
> set.seed(1123); system.time(x <- quickc(runif(100000)))
[1] 163.52 29.56 193.31 0.00 0.00 ...
disassemble(la1c)で覗けば, パース(構文解析)後のデータにな...
なるほど、かなり意味不明のコードに変わっていますね。構文...
> disassemble(la1c)
list(.Code, list(4, GETSYMFUN.OP, 1, MAKEPROM.OP, 2, CAL...
3, SETVAR.OP, 4, POP.OP, GETBUILTIN.OP, 5, GETVAR.OP,...
PUSHARG.OP, CALLBUILTIN.OP, 7, NOT.OP, BRIFNOT.OP, 30...
8, MAKEPROM.OP, 9, CALL.OP, 10, SETVAR.OP, 6, GOTO.OP...
LDNULL.OP, POP.OP, GETINTLBUILTIN.OP, 11, PUSHCONSTAR...
12, GETBUILTIN.OP, 13, GETVAR.OP, 6, PUSHARG.OP, CALL...
14, PUSHARG.OP, CALLBUILTIN.OP, 15, SETVAR.OP, 16, PO...
GETSYMFUN.OP, 17, MAKEPROM.OP, 18, SETTAG.OP, 19, CAL...
20, STARTFOR.OP, 21, 93, GETBUILTIN.OP, 22, GETFUN.OP...
MAKEPROM.OP, 23, DODOTS.OP, CALL.OP, 24, PUSHARG.OP, ...
25, STARTASSIGN.OP, 16, 26, GETVAR.OP, 16, STARTSUBAS...
27, 89, GETVAR.OP, 21, PUSHARG.OP, GETVAR.OP, 26, PUS...
SETTAG.OP, 28, DFLTSUBASSIGN.OP, ENDASSIGN.OP, 16, 26...
STEPFOR.OP, 60, ENDFOR.OP, POP.OP, GETSYMFUN.OP, 29, ...
30, CALL.OP, 31, STARTASSIGN.OP, 16, 26, GETSYMFUN.OP...
MAKEPROM.OP, 33, MAKEPROM.OP, 34, SETTAG.OP, 28, CALL...
35, ENDASSIGN.OP, 16, 26, POP.OP, CALLSPECIAL.OP, 36,...
list({
FUN <- match.fun(FUN)
if (!is.list(X))
X <- as.list(X)
rval <- vector("list", length(X))
for (i in seq(along = X)) rval[i] <- list(FUN(X[[...
...))
names(rval) <- names(X)
return(rval)
}, match.fun, list(.Code, list(4, GETVAR.OP, 0, RETUR...
list(FUN)), match.fun(FUN), FUN, is.list, X, is.l...
as.list, list(.Code, list(4, GETVAR.OP, 0, RETURN...
list(X)), as.list(X), vector, "list", length,...
vector("list", length(X)), rval, seq, list(.Code,...
4, GETVAR.OP, 0, RETURN.OP), list(X)), along,...
i, list, list(.Code, list(4, GETVAR.OP, 1, STARTS...
2, 10, GETVAR.OP, 3, PUSHARG.OP, DFLTSUBSET2....
RETURN.OP), list(X[[i]], X, X[[i]], i)), FUN(...
...), list(FUN(X[[i]], ...)), `*ctmp*`, "[<-"...
i, value = `*ctmp*`), value, names, list(.Cod...
4, GETVAR.OP, 0, RETURN.OP), list(X)), names(...
`names<-`, list(.Code, list(4, GETVAR.OP, 0, RETU...
list(rval)), list(.Code, list(4, GETVAR.OP, 0...
list(`*ctmp*`)), "names<-"(rval, value = `*ct...
return(rval)))
R最適化Tips 中のトランプシミュレーションプログラム test4 ...
> test44 <- function (repl) {
x <- matrixc(0, nrow = 10, ncol=repl)
a <- repc(0:3,13)
for (i in 1:repl) x[,i] <- samplec(a, 10)
y <- matrixc(x, nrow=5)
z <- y - matrixc(y[1,], nrow=5, ncol=2*re...
w <- matrix(colSumsc(abs(z)), nrow=2)
pass <- sumc(w[1,]*w[2,]==0)
pass/repl
}
> test44c <- cmpfun(test44) # 本体もバ...
> set.seed(1111); system.time(test4(10000)) # オリジナ...
[1] 1.11 0.01 1.11 0.00 0.00
> set.seed(1111); system.time(test44c(10000)) # バイト...
[1] 0.58 0.01 0.59 0.00 0.00
> set.seed(1111); system.time(test4(100000)) # オリジ...
[1] 10.66 0.08 10.74 0.00 0.00
> set.seed(1111); system.time(test44c(100000)) # バイト...
[1] 5.71 0.07 5.79 0.00 0.00
しつっこく実験。不思議なことに気づきました。中で使うシス...
> gc(); set.seed(1111); system.time(test4(10000)) # オ...
[1] 1.07 0.02 1.09 0.00 0.00
> gc(); set.seed(1111); system.time(test4c(10000)) # そ...
[1] 0.61 0.01 0.62 0.00 0.00
> gc(); set.seed(1111); system.time(test44(10000)) # 中...
[1] 1.02 0.00 1.02 0.00 0.00
> gc(); set.seed(1111); system.time(test44c(10000)) # そ...
[1] 0.57 0.00 0.57 0.00 0.00
- 2.13.0 のパッケージに含まれていますね。３倍速になるよう...
#comment
ページ名:
![[RjpWiki]](image/../Rlogo.png "[RjpWiki]")
