diff --git a/nCompiler/R/Rcpp_nCompiler_plugin.R b/nCompiler/R/Rcpp_nCompiler_plugin.R index e585bace..549f0e76 100644 --- a/nCompiler/R/Rcpp_nCompiler_plugin.R +++ b/nCompiler/R/Rcpp_nCompiler_plugin.R @@ -15,13 +15,11 @@ inlineCxxPlugin <- function(...) { uses_nC_inter <- !isFALSE(inlineCxxPlugin_env$uses_nC_inter) uses_nList <- !isFALSE(inlineCxxPlugin_env$uses_nList) uses_cereal <- !isFALSE(inlineCxxPlugin_env$uses_cereal) - uses_TBB <- FALSE # !isFALSE(inlineCxxPlugin_env$uses_TBB) # including here causes error due to #defining FALSE include.before <- character() if(uses_eigen) include.before <- paste0(include.before, "#define NCOMPILER_USES_EIGEN\n") if(uses_nC_inter) include.before <- paste0(include.before, "#define NCOMPILER_USES_NCLASS_INTERFACE\n") if(uses_nList) include.before <- paste0(include.before, "#define NCOMPILER_USES_NLIST\n") if(uses_cereal) include.before <- paste0(include.before, "#define NCOMPILER_USES_CEREAL\n") - if(uses_TBB) include.before <- paste0(include.before, "#define NCOMPILER_USES_TBB\n") include.before <- paste0(include.before, "#include ") ans <- Rcpp::Rcpp.plugin.maker(include.before=include.before)() ans @@ -37,9 +35,9 @@ nCompiler_pluginEnv <- new.env() make_nCompiler_plugin <- function(nCompiler_pluginEnv) { RcppDefaultPlugin <- Rcpp:::Rcpp.plugin.maker() force(nCompiler_pluginEnv) - ans <- function(...) { + ans <- function(...) { result <- RcppDefaultPlugin(...) - result$env$PKG_CPPFLAGS <- c(result$env$PKG_CPPFLAGS, + result$env$PKG_CPPFLAGS <- paste(result$env$PKG_CPPFLAGS, if(length(nCompiler_pluginEnv$includePaths) > 0) paste0( "-I", @@ -50,6 +48,8 @@ make_nCompiler_plugin <- function(nCompiler_pluginEnv) { result$env$PKG_LIBS <- get_nCompLocal_PKG_LIBS_entry() ## Makevars doesn't work ## result$Makevars <- "CXX_STD=CXX11" does not seem to work + if(isTRUE(nCompiler_pluginEnv$uses_TBB)) + result$env <- setEnvTBB(result$env) result } ans @@ -74,13 +74,15 @@ make_nCompiler_Eigen_plugin <- function(nCompiler_pluginEnv) { "") # result$env$PKG_CXXFLAGS <- "-std=c++11" result$env$PKG_LIBS <- get_nCompLocal_PKG_LIBS_entry() + if(!isFALSE(inlineCxxPlugin_env$uses_TBB)) + result$env <- setEnvTBB(result$env) if(isTRUE(get_nOption('compilerOptions')$throwEigenErrors)) { # replace include directives to enable Eigen errors #preamble = system.file(file.path('include', 'nCompiler', # 'nCompiler_Eigen_EnableErrors.h'), # package = 'nCompiler') #result$includes = readChar(preamble, file.info(preamble)$size) - result$includes = "#define NCOMPILER_HANDLE_EIGEN_ERRORS" + result$includes = c("#define NCOMPILER_HANDLE_EIGEN_ERRORS") } if(isTRUE(get_nOption('compilerOptions')$cppStacktrace)) { # add include directives to add stack basic traces @@ -95,3 +97,13 @@ make_nCompiler_Eigen_plugin <- function(nCompiler_pluginEnv) { } nCompiler_Eigen_plugin <- make_nCompiler_Eigen_plugin(nCompiler_pluginEnv) + +setEnvTBB <- function(env) { + if(.Platform$OS.type == "windows") { + env$PKG_CPPFLAGS <- paste(env$PKG_CPPFLAGS, '-DRCPP_PARALLEL_USE_TBB=1') + env$PKG_LIBS <- paste(env$PKG_LIBS, + '$(shell "${R_HOME}/bin${R_ARCH_BIN}/Rscript.exe"-e "RcppParallel::RcppParallelLibs()")') + } else env$PKG_LIBS <- paste(env$PKG_LIBS, + '$(shell ${R_HOME}/bin/Rscript -e "RcppParallel::RcppParallelLibs()")') + return(env) +} diff --git a/nCompiler/R/compile_finalTransformations.R b/nCompiler/R/compile_finalTransformations.R index dd817da1..103b04fb 100644 --- a/nCompiler/R/compile_finalTransformations.R +++ b/nCompiler/R/compile_finalTransformations.R @@ -168,6 +168,7 @@ inFinalTransformationsEnv( ## code$args[[4]] <- copyVars ## This is no longer an exprClass ## code$args[[5]] <- shareVars ## Ditto + ## We have already found the local method calls and set the `opInfo$case` to be 'nClass_method_in_lifted', ## such that C++ calls to the method will be handled by cppOutput handler. ## The following checks for such methods in a different way (so perhaps worry an inconsistency could arise). @@ -184,6 +185,7 @@ inFinalTransformationsEnv( vector_arg <- removeArg(code, 'object') init_arg <- removeArg(code, 'init') nThreads_arg <- removeArg(code, 'nThreads') + ## add an index var index_arg <- exprClass$new(name = 'i__', isName = TRUE, isCall = FALSE, isLiteral = FALSE, isAssign = FALSE) diff --git a/nCompiler/R/compile_generateCpp.R b/nCompiler/R/compile_generateCpp.R index 15cd43dc..78339be4 100644 --- a/nCompiler/R/compile_generateCpp.R +++ b/nCompiler/R/compile_generateCpp.R @@ -617,10 +617,12 @@ inGenCppEnv( ParallelExpr <- function(code, symTab) { nThreads_arg <- removeArg(code, 3) paste0('{', - paste0('tbb::global_control gc(tbb::global_control::max_allowed_parallelism, getNumThreads(', - compile_generateCpp(nThreads_arg, symTab), - '));'), - paste0(eval(call("AsIs", code, symTab), envir = genCppEnv), ';'), - '}', collapse = '\n') + "depth_counter mydc;", ## This increments TBB_DEPTH and destructor will decrement. + paste0('tbb::global_control gc(tbb::global_control::max_allowed_parallelism, getNumThreads(', + compile_generateCpp(nThreads_arg, symTab), + '));'), + AsIs(code, symTab), + ';}', + collapse = '\n') } ) diff --git a/nCompiler/R/compile_labelAbstractTypes.R b/nCompiler/R/compile_labelAbstractTypes.R index 420f302b..1195619f 100644 --- a/nCompiler/R/compile_labelAbstractTypes.R +++ b/nCompiler/R/compile_labelAbstractTypes.R @@ -765,6 +765,9 @@ inLabelAbstractTypesEnv( ## the loop body with the loop body C++ function declaring its own variables. symbolsNoBody <- symTab$getSymbolNames() inserts <- c(inserts, compile_labelAbstractTypes(code$args[[3]], symTab, auxEnv)) + + auxEnv$uses_TBB <- TRUE + nCompiler_pluginEnv$uses_TBB <- TRUE ## I think there shouldn't be any inserts returned since the body should be a bracket expression. symbols <- symTab$getSymbolNames() code$aux$localVars <- symbols[!symbols %in% symbolsNoBody] @@ -885,7 +888,10 @@ inLabelAbstractTypesEnv( inserts <- c(inserts, compile_labelAbstractTypes(code$args[['nThreads']], symTab, auxEnv)) - + + auxEnv$uses_TBB <- TRUE + nCompiler_pluginEnv$uses_TBB <- TRUE + return(if (length(inserts) == 0) invisible(NULL) else inserts) } ) diff --git a/nCompiler/R/cppDefs_R_interface_calls.R b/nCompiler/R/cppDefs_R_interface_calls.R index 015123ab..b1792d4a 100644 --- a/nCompiler/R/cppDefs_R_interface_calls.R +++ b/nCompiler/R/cppDefs_R_interface_calls.R @@ -46,7 +46,7 @@ global_R_interface_cppDef <- " get_genericInterfaceBaseC(Xptr);\n", " // std::cout << name << std::endl;\n", " return(obj->call_method( name, Sargs ));\n", - "}\n"), + "};\n"), name = "R_interfaces" ) diff --git a/nCompiler/R/cppDefs_nClass.R b/nCompiler/R/cppDefs_nClass.R index 892de2be..96de0900 100644 --- a/nCompiler/R/cppDefs_nClass.R +++ b/nCompiler/R/cppDefs_nClass.R @@ -11,13 +11,11 @@ nClassBaseClass_init_impl <- function(cppDef) { cppDef$Hpreamble <- pluginIncludes cppDef$Hpreamble <- c(cppDef$Hpreamble, "#define NCOMPILER_USES_EIGEN", - "#define NCOMPILER_USES_TBB", "#define NCOMPILER_USES_NLIST", "#define USES_NCOMPILER") cppDef$CPPpreamble <- pluginIncludes cppDef$CPPpreamble <- c(cppDef$CPPpreamble, "#define NCOMPILER_USES_EIGEN", - "#define NCOMPILER_USES_TBB", "#define NCOMPILER_USES_NLIST", "#define USES_NCOMPILER") @@ -114,6 +112,13 @@ cpp_nClassBaseClass <- R6::R6Class( cpp_include_needed_nClasses(self, Compiler$symbolTable) symbolTable <<- symbolTable2cppSymbolTable(Compiler$symbolTable) # variableNamesForInterface <<- symbolTable$getSymbolNames() + uses_TBB <- any(sapply(Compiler$NFcompilers, function(x) isTRUE(x$auxEnv$uses_TBB))) + if(uses_TBB) { + self$Hpreamble <- c(self$Hpreamble, + "#define NCOMPILER_USES_TBB") + self$CPPpreamble <- c(self$CPPpreamble, + "#define NCOMPILER_USES_TBB") + } }, buildAll = function(where = where) { buildDefaultSEXPgenerator <- !isFALSE(self$compileInfo$createFromR) diff --git a/nCompiler/R/cppDefs_nFunction.R b/nCompiler/R/cppDefs_nFunction.R index 6bd56703..0a8e59cc 100644 --- a/nCompiler/R/cppDefs_nFunction.R +++ b/nCompiler/R/cppDefs_nFunction.R @@ -8,7 +8,6 @@ cpp_nFunctionClass_init_impl <- function(cppDef) { cppDef$Hpreamble <- pluginIncludes cppDef$Hpreamble <- c(cppDef$Hpreamble, "#define NCOMPILER_USES_EIGEN", - "#define NCOMPILER_USES_TBB", "#define NCOMPILER_USES_NLIST", "#define USES_NCOMPILER") ## handler nList in labelAbstractTypes does record in auxEnv if an @@ -19,7 +18,6 @@ cpp_nFunctionClass_init_impl <- function(cppDef) { cppDef$CPPpreamble <- pluginIncludes cppDef$CPPpreamble <- c(cppDef$CPPpreamble, "#define NCOMPILER_USES_EIGEN", - "#define NCOMPILER_USES_TBB", "#define NCOMPILER_USES_NLIST", "#define USES_NCOMPILER") cppDef$Hincludes <- c(cppDef$Hincludes)#, diff --git a/nCompiler/R/nCompile.R b/nCompiler/R/nCompile.R index cf4d3d54..49ab08ea 100644 --- a/nCompiler/R/nCompile.R +++ b/nCompiler/R/nCompile.R @@ -1268,7 +1268,9 @@ WP_write_DESCRIPTION_NAMESPACE <- function(units, unitTypes, interfaces, createF # DESCRIPTION[1, "Collate"] <- paste(Rfilepath, collapse = ", ") write.dcf(DESCRIPTION, DESCfile) NAMESPACE <- c(paste0("useDynLib(", pkgName, ", .registration=TRUE)"), - "importFrom(Rcpp, evalCpp)"# , # required at package loading + "importFrom(Rcpp, evalCpp)", # required at package loading + if(!isFALSE(inlineCxxPlugin_env$uses_TBB)) + "importFrom(RcppParallel, RcppParallelLibs)" else NULL # "export(nComp_serialize_)", # "export(nComp_deserialize_)", # "export(call_method)", diff --git a/nCompiler/inst/include/nCompiler/nCompiler_omnibus.h b/nCompiler/inst/include/nCompiler/nCompiler_omnibus.h index 419f653e..4e9d22b7 100644 --- a/nCompiler/inst/include/nCompiler/nCompiler_omnibus.h +++ b/nCompiler/inst/include/nCompiler/nCompiler_omnibus.h @@ -23,6 +23,23 @@ //#ifndef NCOMPILER_OMNIBUS_FIRST_CPP_ // #define NCOMPILER_OMNIBUS_FIRST_CPP_ +// Despite use of `inline` and C++17, TBB_DEPTH is being defined multiple times. +// Also, I think I need the include guard for the class definition anyway. +// The header guard is needed for the class definition and to +// avoid multiple definitions of `TBB_DEPTH` (despite the `inline`; I +// don't fully understand that). +#ifndef TBB_DEPTH_H +#define TBB_DEPTH_H + +inline int TBB_DEPTH = 0; + +class depth_counter { + public: + depth_counter() { TBB_DEPTH++; } + ~depth_counter() { TBB_DEPTH--; } +}; +#endif + #include "nCompiler_omnibus_pre_Rcpp.h" // should always be redundant, but it is here to be clear // We shall see if these two "first" files (_h and _cpp) are really needed or can be consolidated. diff --git a/nCompiler/inst/include/nCompiler/utils.h b/nCompiler/inst/include/nCompiler/utils.h index 4018dc48..e2b6e543 100644 --- a/nCompiler/inst/include/nCompiler/utils.h +++ b/nCompiler/inst/include/nCompiler/utils.h @@ -1,10 +1,13 @@ inline int getNumThreads(double value_) { + static int nThreads_nOption=0; // This variable is preserved across calls. + if(TBB_DEPTH==1) { // Avoid calls to R API within threads. + Rcpp::Environment nc = Rcpp::Environment::namespace_env("nCompiler"); + Rcpp::Function get_nOption = nc["get_nOption"]; + nThreads_nOption=Rcpp::as(get_nOption("nThreads")); + } int value = (int) value_; - Rcpp::Environment nc = Rcpp::Environment::namespace_env("nCompiler"); - Rcpp::Function get_nOption = nc["get_nOption"]; - int option_value = Rcpp::as(get_nOption("nThreads")); - if (option_value > 0) - value = option_value; + if (nThreads_nOption > 0) + value = nThreads_nOption; if(value == 0) value = 100000; return value; diff --git a/nCompiler/tests/testthat/tbb_tests/test-parallel_for.R b/nCompiler/tests/testthat/tbb_tests/test-parallel_for.R index 91f93c16..84662cce 100644 --- a/nCompiler/tests/testthat/tbb_tests/test-parallel_for.R +++ b/nCompiler/tests/testthat/tbb_tests/test-parallel_for.R @@ -346,7 +346,7 @@ test_that("multiple non-nested loops", { expect_identical(Cobj$go2(2:6,100:104), as.numeric(2*(2:6)+100:104+3)) }) -test_that("nested loops", { # See issue 152. +test_that("nested loops", { nc <- nClass( Cpublic = list(