C stack usage is too close to the limit when loading a Module

[bgoodri]

With 3.3.0 beta (2016-04-05 r70427) from Debian unstable I am having an issue with loading the Modules in the rstanarm package that does not occur on r-devel compiled from svn and was not occurring with 3.2.x. So, this might be a Debian bug, but it occurs whether I use r-cran-rcpp or install Rcpp 0.12.4 from CRAN (with various combinations of CXXFLAGS in ~/.R/Makevars).

In .onLoad(), I call loadRcppModules() to load the six modules listed in the RcppModules line of the DESCRIPTION file. This has worked for months and I'm pretty sure it was working with the Rcpp 0.12.4 for a few days before the 3.3.0 betas starting being uploaded to Debian unstable. Now, when it tries to the load the rstanarm package, it errors with "C stack usage is too close to the limit". If you have the 3.3.0 beta from Debian unstable, you should be able to reproduce this just by calling

install.packages("rstanarm")

If I first call ulimit -s 16384 in a shell to increase the stack limit, the error message becomes

** testing if installed package can be loaded
Error : .onLoad failed in loadNamespace() for 'rstanarm', details:
  call: value[[3L]](cond)
  error: failed to load module stan_fit4bernoulli_mod from package rstanarm
evaluation nested too deeply: infinite recursion / options(expressions=)?
Error: loading failed
Execution halted
ERROR: loading failed

To investigate, I commented out loadRcppModules() in .onLoad() and tried to load one of rstanarm's Modules manually. The error comes from the Module() function when it calls clname <- as.character(CLASS). The full session is below:

library(rstanarm) # with loadRcppModules() commented out in .onLoad()
library(Rcpp)
mod <- Module("stan_fit4bernoulli_mod", "rstanarm")
debug(Module)
populate(mod, .GlobalEnv)
debugging in: Module(module, mustStart = TRUE)
debug: {
    if (inherits(module, "DLLInfo") && missing(mustStart)) 
        mustStart <- TRUE
    if (inherits(module, "Module")) {
        xp <- .getModulePointer(module, FALSE)
        if (!missing(PACKAGE)) 
            warning("ignoring PACKAGE argument in favor of internal package from Module object")
        env <- as.environment(module)
        PACKAGE <- get("packageName", envir = env)
        moduleName <- get("moduleName", envir = env)
    }
    else if (identical(typeof(module), "externalptr")) {
        xp <- module
        moduleName <- .Call(Module__name, xp)
        module <- methods::new("Module", pointer = xp, packageName = PACKAGE, 
            moduleName = moduleName)
    }
    else if (is.character(module)) {
        moduleName <- module
        xp <- .badModulePointer
        module <- methods::new("Module", pointer = xp, packageName = PACKAGE, 
            moduleName = moduleName)
    }
    if (identical(xp, .badModulePointer)) {
        if (mustStart) {
            name <- sprintf("_rcpp_module_boot_%s", moduleName)
            symbol <- tryCatch(getNativeSymbolInfo(name, PACKAGE), 
                error = function(e) e)
            if (inherits(symbol, "error")) 
                stop(gettextf("Failed to initialize module pointer: %s", 
                  symbol), domain = NA)
            xp <- .Call(symbol)
            .setModulePointer(module, xp)
        }
        else return(module)
    }
    classes <- .Call(Module__classes_info, xp)
    if (environmentIsLocked(where)) 
        where <- .GlobalEnv
    generators <- list()
    storage <- new.env()
    for (i in seq_along(classes)) {
        CLASS <- classes[[i]]
        clname <- as.character(CLASS)
        fields <- cpp_fields(CLASS, where)
        methods <- cpp_refMethods(CLASS, where)
        generator <- methods::setRefClass(clname, fields = fields, 
            contains = "C++Object", methods = methods, where = where)
        .self <- .refClassDef <- NULL
        generator$methods(initialize = if (cpp_hasDefaultConstructor(CLASS)) 
            function(...) cpp_object_initializer(.self, .refClassDef, 
                ...)
        else function(...) {
            if (nargs()) 
                cpp_object_initializer(.self, .refClassDef, ...)
            else cpp_object_dummy(.self, .refClassDef)
        })
        rm(.self, .refClassDef)
        classDef <- methods::getClass(clname)
        fields <- classDef@fieldPrototypes
        assign(".pointer", CLASS@pointer, envir = fields)
        assign(".module", xp, envir = fields)
        assign(".CppClassName", clname, envir = fields)
        generators[[clname]] <- generator
        if (any(grepl("^[[]", names(CLASS@methods)))) {
            if ("[[" %in% names(CLASS@methods)) {
                methods::setMethod("[[", clname, function(x, 
                  i, j, ..., exact = TRUE) {
                  x$`[[`(i)
                }, where = where)
            }
            if ("[[<-" %in% names(CLASS@methods)) {
                methods::setReplaceMethod("[[", clname, function(x, 
                  i, j, ..., exact = TRUE, value) {
                  x$`[[<-`(i, value)
                  x
                }, where = where)
            }
        }
        if (any(grepl("show", names(CLASS@methods)))) {
            setMethod("show", clname, function(object) object$show(), 
                where = where)
        }
    }
    if (length(classes)) {
        module$refClassGenerators <- generators
    }
    for (i in seq_along(classes)) {
        CLASS <- classes[[i]]
        clname <- as.character(CLASS)
        demangled_name <- sub("^Rcpp_", "", clname)
        .classes_map[[CLASS@typeid]] <- storage[[demangled_name]] <- .get_Module_Class(module, 
            demangled_name, xp)
        if (length(CLASS@enums)) {
            for (enum in CLASS@enums) {
                for (i in 1:length(enum)) {
                  storage[[paste(demangled_name, ".", names(enum)[i], 
                    sep = "")]] <- enum[i]
                }
            }
        }
    }
    functions <- .Call(Module__functions_names, xp)
    for (fun in functions) {
        storage[[fun]] <- .get_Module_function(module, fun, xp)
        converter_rx <- "^[.]___converter___(.*)___(.*)$"
        if (length(matches <- grep(converter_rx, functions))) {
            for (i in matches) {
                fun <- functions[i]
                from <- sub(converter_rx, "\\1", fun)
                to <- sub(converter_rx, "\\2", fun)
                converter <- function(from) {
                }
                body(converter) <- substitute({
                  CONVERT(from)
                }, list(CONVERT = storage[[fun]]))
                setAs(from, to, converter, where = where)
            }
        }
    }
    assign("storage", storage, envir = as.environment(module))
    module
}
Browse[2]> 
debug: if (inherits(module, "DLLInfo") && missing(mustStart)) mustStart <- TRUE
Browse[2]> 
debug: if (inherits(module, "Module")) {
    xp <- .getModulePointer(module, FALSE)
    if (!missing(PACKAGE)) 
        warning("ignoring PACKAGE argument in favor of internal package from Module object")
    env <- as.environment(module)
    PACKAGE <- get("packageName", envir = env)
    moduleName <- get("moduleName", envir = env)
} else if (identical(typeof(module), "externalptr")) {
    xp <- module
    moduleName <- .Call(Module__name, xp)
    module <- methods::new("Module", pointer = xp, packageName = PACKAGE, 
        moduleName = moduleName)
} else if (is.character(module)) {
    moduleName <- module
    xp <- .badModulePointer
    module <- methods::new("Module", pointer = xp, packageName = PACKAGE, 
        moduleName = moduleName)
}
Browse[2]> 
debug: xp <- .getModulePointer(module, FALSE)
Browse[2]> 
debug: if (!missing(PACKAGE)) warning("ignoring PACKAGE argument in favor of internal package from Module object")
Browse[2]> 
debug: env <- as.environment(module)
Browse[2]> 
debug: PACKAGE <- get("packageName", envir = env)
Browse[2]> 
debug: moduleName <- get("moduleName", envir = env)
Browse[2]> 
debug: if (identical(xp, .badModulePointer)) {
    if (mustStart) {
        name <- sprintf("_rcpp_module_boot_%s", moduleName)
        symbol <- tryCatch(getNativeSymbolInfo(name, PACKAGE), 
            error = function(e) e)
        if (inherits(symbol, "error")) 
            stop(gettextf("Failed to initialize module pointer: %s", 
                symbol), domain = NA)
        xp <- .Call(symbol)
        .setModulePointer(module, xp)
    }
    else return(module)
}
Browse[2]> 
debug: if (mustStart) {
    name <- sprintf("_rcpp_module_boot_%s", moduleName)
    symbol <- tryCatch(getNativeSymbolInfo(name, PACKAGE), error = function(e) e)
    if (inherits(symbol, "error")) 
        stop(gettextf("Failed to initialize module pointer: %s", 
            symbol), domain = NA)
    xp <- .Call(symbol)
    .setModulePointer(module, xp)
} else return(module)
Browse[2]> 
debug: name <- sprintf("_rcpp_module_boot_%s", moduleName)
Browse[2]> 
debug: symbol <- tryCatch(getNativeSymbolInfo(name, PACKAGE), error = function(e) e)
Browse[2]> 
debug: if (inherits(symbol, "error")) stop(gettextf("Failed to initialize module pointer: %s", 
    symbol), domain = NA)
Browse[2]> 
debug: xp <- .Call(symbol)
Browse[2]> 
debug: .setModulePointer(module, xp)
Browse[2]> 
debug: classes <- .Call(Module__classes_info, xp)
Browse[2]> 
debug: if (environmentIsLocked(where)) where <- .GlobalEnv
Browse[2]> 
debug: where <- .GlobalEnv
Browse[2]> 
debug: generators <- list()
Browse[2]> 
debug: storage <- new.env()
Browse[2]> 
debug: for (i in seq_along(classes)) {
    CLASS <- classes[[i]]
    clname <- as.character(CLASS)
    fields <- cpp_fields(CLASS, where)
    methods <- cpp_refMethods(CLASS, where)
    generator <- methods::setRefClass(clname, fields = fields, 
        contains = "C++Object", methods = methods, where = where)
    .self <- .refClassDef <- NULL
    generator$methods(initialize = if (cpp_hasDefaultConstructor(CLASS)) 
        function(...) cpp_object_initializer(.self, .refClassDef, 
            ...)
    else function(...) {
        if (nargs()) 
            cpp_object_initializer(.self, .refClassDef, ...)
        else cpp_object_dummy(.self, .refClassDef)
    })
    rm(.self, .refClassDef)
    classDef <- methods::getClass(clname)
    fields <- classDef@fieldPrototypes
    assign(".pointer", CLASS@pointer, envir = fields)
    assign(".module", xp, envir = fields)
    assign(".CppClassName", clname, envir = fields)
    generators[[clname]] <- generator
    if (any(grepl("^[[]", names(CLASS@methods)))) {
        if ("[[" %in% names(CLASS@methods)) {
            methods::setMethod("[[", clname, function(x, i, j, 
                ..., exact = TRUE) {
                x$`[[`(i)
            }, where = where)
        }
        if ("[[<-" %in% names(CLASS@methods)) {
            methods::setReplaceMethod("[[", clname, function(x, 
                i, j, ..., exact = TRUE, value) {
                x$`[[<-`(i, value)
                x
            }, where = where)
        }
    }
    if (any(grepl("show", names(CLASS@methods)))) {
        setMethod("show", clname, function(object) object$show(), 
            where = where)
    }
}
Browse[2]> 
debug: CLASS <- classes[[i]]
Browse[2]> 
debug: clname <- as.character(CLASS) # before this executes, I print CLASS
Browse[2]> CLASS
C++ class 'model_bernoulli' <0x8a94400>
Constructors:
    model_bernoulli(SEXP, SEXP)

Fields: No public fields exposed by this class

Methods: 
     SEXP call_sampler(SEXP)  

     SEXP constrain_pars(SEXP)  

     SEXP constrained_param_names(SEXP, SEXP)  

     SEXP grad_log_prob(SEXP, SEXP)  

     SEXP log_prob(SEXP, SEXP, SEXP)  

     SEXP num_pars_unconstrained()  

     SEXP param_dims()  const 

     SEXP param_dims_oi()  const 

     SEXP param_fnames_oi()  const 

     SEXP param_names()  const 

     SEXP param_names_oi()  const 

     SEXP param_oi_tidx(SEXP)  

     SEXP unconstrain_pars(SEXP)  

     SEXP unconstrained_param_names(SEXP, SEXP)  

     SEXP update_param_oi(SEXP)  

Browse[2]> # one more Enter executes as.character(CLASS)
Error: C stack usage  7970004 is too close to the limit

Thanks!

[eddelbuettel]

@bgoodri It is difficult to say anything here. The bug may be due to a race condition that's always been there. R-devel made a change last summer that affected modules, and we accommodated. Here maybe the 'memory-profiling' default in the Debian package is the difference, otherwise

With 3.3.0 beta (2016-04-05 r70427) from Debian unstable I am having an issue with loading the Modules in the rstanarm package that does not occur on r-devel compiled from svn and was not occurring with 3.2.x.

is pretty impossible. You could try compiling r-devel the same way as my Debian package.

[bgoodri]

Thanks @eddelbuettel . I tried to build r-devel like r-base but got the same error. Is there more to it than taking just the configure.stamp stanza from debian/rules and pasting it into the shell where r-devel is? Like

        R_TEXI2DVICMD=emulation                         \
        R_PAPERSIZE=letter                              \
...
        ./configure --prefix=/usr                       \
...
                    --without-recommended-packages      \
                    --build $(buildarch)

Regardless, I was able to get it to work again with r-base if I hacked the Module.R file in three places

1. Line 114: value@generator <- get("refClassGenerators",envir=x)[[as.character(value)]] changed to value@generator <- get("refClassGenerators", envir=x)[[value@.Data]]
2. Line 219 clname <- as.character(CLASS) changed to clname <- as.character(CLASS@.Data)
3. Line 281 clname <- as.character(CLASS) changed to clname <- as.character(CLASS@.Data)

I'm not sure what as.character is dispatching to for a C++Object but that is apparently where the race is triggered.

[eddelbuettel]

I was able to replicate this in a Debian unstable Docker container with the current R package.

Could you prepare a proper pull request detailing your changes (and maybe adding a ChangeLog entry) so that it gets at least passed through Travis one time?