Build model methods and exposed functions against RcppParallel's TBB when it is installed

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

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
 

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,

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", {

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 <Rcpp.h>",
+    "#include <tbb/version.h>",
+    "// [[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)))
 })