handle nested TBB in thread-safe fashion

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 <nCompiler/nCompiler_omnibus.h>")
   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)
+}

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)

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')
   }
 )

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)
   }
 )

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"
   )
 

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)

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)#,

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

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.

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<int>(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<int>(get_nOption("nThreads"));
-  if (option_value > 0)
-    value = option_value;
+  if (nThreads_nOption > 0)
+    value = nThreads_nOption;
   if(value == 0)
     value = 100000;
   return value;

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(