diff --git a/DESCRIPTION b/DESCRIPTION index 59da5a10a..e9b30dffd 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -58,7 +58,8 @@ Suggests: qs2, rmarkdown, testthat (>= 3.3.0), - Rcpp + Rcpp, + RcppParallel VignetteBuilder: knitr Config/testthat/edition: 3 Config/roxygen2/version: 8.0.0 diff --git a/NEWS.md b/NEWS.md index 98fd61c26..e18d2eadb 100644 --- a/NEWS.md +++ b/NEWS.md @@ -251,6 +251,9 @@ and saying how to rebuild it. Previously the fitting methods and * On Windows a model executable is now launched with the TBB it was built against. Previously the selected CmdStan installation's TBB was used, which was wrong once `set_cmdstan_path()` had selected a different one. (#1261) +* `$init_model_methods()` and `$expose_functions()` now work in a session that +has loaded rstan or brms, by building against RcppParallel's TBB when +RcppParallel is installed. (#1270) ## Removed and deprecated diff --git a/R/expose.R b/R/expose.R index 83d682aca..21b4d4aad 100644 --- a/R/expose.R +++ b/R/expose.R @@ -25,18 +25,77 @@ check_sundials_fpic <- function(verbose) { } } +#' RcppParallel's TBB, to build R-loaded code against +#' +#' CmdStan bundles TBB 2020.3 and RcppParallel ships oneTBB under the +#' same library name (`libtbb.dylib`, `tbb.dll`, `libtbb.so.2`). Once +#' one copy is in the process, code linked against the other fails to +#' load: model methods built after rstan or brms loaded RcppParallel's, +#' or RcppParallel itself after the methods loaded CmdStan's. Building +#' the methods against RcppParallel's copy whenever it is installed +#' avoids both orders. Stan Math supports oneTBB through +#' `TBB_INTERFACE_NEW`. +#' +#' @return A list with RcppParallel's `include` and `lib` directories, +#' or `NULL` when RcppParallel is not installed with its oneTBB. +#' @noRd +rcppparallel_tbb <- function() { + arch <- .Platform$r_arch + lib <- system.file(paste(c("lib", arch[nzchar(arch)]), collapse = "/"), + package = "RcppParallel") + version_h <- system.file("include/tbb/version.h", package = "RcppParallel") + if (!nzchar(lib) || !nzchar(version_h)) { + return(NULL) + } + # R CMD check's temporary library returns backslash paths on Windows + list(include = repair_path(dirname(dirname(version_h))), + lib = repair_path(lib)) +} + +#' Compile C++ that uses the Stan Math library and load it into R +#' +#' Wraps `Rcpp::sourceCpp()` with the include paths, defines and link +#' flags the selected CmdStan installation's make would use for a model, +#' with RcppParallel's TBB substituted when it is installed, see +#' `rcppparallel_tbb()`. +#' +#' @param code Character string with the C++ source. +#' @param env Environment the compiled functions are assigned into. +#' @param verbose Logical. Print compiler output and, on Linux, the +#' SUNDIALS rebuild output? +#' @param ... Passed to `Rcpp::sourceCpp()`. +#' @return `NULL`, invisibly. +#' @noRd rcpp_source_stan <- function(code, env, verbose = FALSE, ...) { check_sundials_fpic(verbose) - cxxflags <- get_cmdstan_flags("CXXFLAGS") - cppflags <- get_cmdstan_flags("CPPFLAGS") + tbb <- rcppparallel_tbb() + make_args <- character() + tbb_dir <- tbb_path() + if (!is.null(tbb)) { + make_args <- c(paste0("TBB_INC=", tbb$include), + paste0("TBB_LIB=", tbb$lib), "TBB_INTERFACE_NEW=1") + if (.Platform$OS.type == "windows") { + # Rtools' linkers reject the ELF-only flag make adds for a system TBB + make_args <- c(make_args, "LDFLAGS_TBB_DTAGS=") + } + tbb_dir <- tbb$lib + } + cxxflags <- get_cmdstan_flags("CXXFLAGS", make_args) + cppflags <- get_cmdstan_flags("CPPFLAGS", make_args) cmdstanr_includes <- system.file("include", package = "cmdstanr", mustWork = TRUE) cmdstanr_includes <- paste0(" -I\"", cmdstanr_includes,"\"") libs <- c("LDLIBS", "LIBSUNDIALS", "TBB_TARGETS", "LDFLAGS_TBB", "SUNDIALS_TARGETS") - libs <- paste(sapply(libs, get_cmdstan_flags), collapse = " ") + libs <- paste(sapply(libs, get_cmdstan_flags, make_args = make_args), + collapse = " ") + if (!is.null(tbb)) { + # make's print rule drops the quotes, so quote the paths here + cxxflags <- gsub(tbb$include, shQuote(tbb$include), cxxflags, fixed = TRUE) + libs <- gsub(tbb$lib, shQuote(tbb$lib), libs, fixed = TRUE) + } if (.Platform$OS.type == "windows") { libs <- paste(libs, "-fopenmp") } - withr::with_path(repair_path(file.path(cmdstan_path(),"stan/lib/stan_math/lib/tbb")), + withr::with_path(tbb_dir, withr::with_makevars( c( USE_CXX14 = 1, diff --git a/tests/testthat/test-model-compile.R b/tests/testthat/test-model-compile.R index c66f870a9..3f375fc3c 100644 --- a/tests/testthat/test-model-compile.R +++ b/tests/testthat/test-model-compile.R @@ -138,7 +138,7 @@ test_that("a program stanc rejects errors with stanc's message", { stan_file <- testing_stan_file("fail") expect_error( cmdstan_model(stan_file), - "Semantic error in '.*fail.stan', line 7" + "fail.stan(', line 7|:7:)" ) }) @@ -539,7 +539,7 @@ test_that("building errors on removed syntax", { } " stan_file <- write_stan_file(model_code) - expect_error(cmdstan_model(stan_file), "Syntax error in '.*', line 4") + expect_error(cmdstan_model(stan_file), "Syntax error.*(line 4|:4:)") }) test_that("compilation errors if folder with the model name exists", { diff --git a/tests/testthat/test-model-methods.R b/tests/testthat/test-model-methods.R index 50736bb19..dc13b5b07 100644 --- a/tests/testthat/test-model-methods.R +++ b/tests/testthat/test-model-methods.R @@ -7,6 +7,33 @@ utils::capture.output( fit <- mod$sample(data = data_list, chains = 1, refresh = 0) ) +test_that("RcppParallel's TBB works from a library path with a space", { + skip_if_not_installed("RcppParallel") + tbb <- rcppparallel_tbb() + skip_if(is.null(tbb), "RcppParallel is built against a system TBB") + installed <- find.package("RcppParallel") + lib <- repair_path(withr::local_tempdir("R library")) + file.copy(installed, lib, recursive = TRUE) + copy <- lapply(tbb, function(dir) { + sub(installed, file.path(lib, "RcppParallel"), dir, fixed = TRUE) + }) + local_mocked_bindings(rcppparallel_tbb = function() copy) + code <- paste( + "#include ", + "#include ", + "// [[Rcpp::export]]", + "int tbb_interface_version() { return TBB_INTERFACE_VERSION; }", + sep = "\n" + ) + expect_no_error(rcpp_source_stan(code, new.env())) +}) + +test_that("model methods load with RcppParallel's TBB in the session", { + skip_if_not_installed("RcppParallel") + loadNamespace("RcppParallel") + expect_no_error(fit$init_model_methods()) +}) + test_that("Model methods automatically initialise when needed", { expect_no_error(fit$log_prob(unconstrained_variables=c(0.1))) })