install.libs.R

# !diagnostics suppress=R_PACKAGE_DIR,SHLIB_EXT,R_ARCH
.install.libs <- function(tbbLib) {

   # copy default library
   files <- Sys.glob(paste0("*", SHLIB_EXT))
   dest <- file.path(R_PACKAGE_DIR, paste0("libs", R_ARCH))
   dir.create(dest, recursive = TRUE, showWarnings = FALSE)
   file.copy(files, dest, overwrite = TRUE)

   # copy symbols if available
   if (file.exists("symbols.rds"))
      file.copy("symbols.rds", dest, overwrite = TRUE)

   # also copy to package 'libs' folder, for devtools
   libsDest <- paste0("../libs", R_ARCH)
   dir.create(libsDest, recursive = TRUE, showWarnings = FALSE)
   file.copy(files, libsDest, overwrite = TRUE)

   # copy tbb (NOTE: do not use inst/ folder as R will resolve symlinks,
   # behavior which we do _not_ want here!)
   tbbDest <- file.path(R_PACKAGE_DIR, paste0("lib", R_ARCH))
   dir.create(tbbDest, recursive = TRUE, showWarnings = FALSE)

   # note: on Linux, TBB gets compiled with extensions like
   # '.so.2', so be ready to handle those
   shlibPattern <- switch(
      Sys.info()[["sysname"]],
      Windows = "^tbb.*\\.dll$",
      Darwin  = "^libtbb.*\\.dylib$",
      "^libtbb.*\\.so.*$"
   )
   # WASM only supports static libraries
   if (R.version$os == "emscripten") {
      shlibPattern <- "^libtbb.*\\.a$"
   }

   if (!nzchar(tbbLib)) {

      # using bundled TBB
      tbbSrc <- "tbb/build/lib_release"
      tbbLibs <- list.files(
         path       = tbbSrc,
         pattern    = shlibPattern,
         full.names = TRUE
      )

      logTbbLibraries(tbbLibs, tbbSrc)
      for (tbbLib in tbbLibs) {
         system2("cp", c("-P", shQuote(tbbLib), shQuote(tbbDest)))
      }

      # restore the versioned library layout shipped by RcppParallel 5.1.11
      # and earlier (a real 'libtbb.so.2' plus a 'libtbb.so' symlink)
      if (Sys.info()[["sysname"]] == "Linux")
         versionBundledTbbLibraries(tbbDest)

   } else {

      # using system tbb
      tbbLibs <- list.files(
         path       = tbbLib,
         pattern    = shlibPattern,
         full.names = TRUE
      )

      # don't copy symlinks
      tbbLibs <- tbbLibs[!nzchar(Sys.readlink(tbbLibs))]

      # copy / link the libraries
      logTbbLibraries(tbbLibs, tbbLib)
      useSymlinks <- Sys.getenv("TBB_USE_SYMLINKS", unset = .Platform$OS.type != "windows")
      if (useSymlinks) {
         file.symlink(tbbLibs, tbbDest)
      } else {
         for (tbbLib in tbbLibs) {
            system2("cp", c("-P", shQuote(tbbLib), shQuote(tbbDest)))
         }
      }

   }

}

# Give the bundled TBB libraries the versioned '.so.<N>' names, plus an
# unversioned 'libtbb.so' compatibility symlink, that RcppParallel shipped on
# Linux through 5.1.11. That layout came from Intel TBB's make-based build,
# which set the library SONAME from TBB_COMPATIBLE_INTERFACE_VERSION (2) and
# emitted 'libtbb.so' as a linker script pointing at 'libtbb.so.2'. The
# oneTBB cmake build only versions its output on Windows, so on Linux it
# produces unversioned libraries (e.g. 'libtbb.so' with SONAME 'libtbb.so')
# instead. Binaries compiled against RcppParallel <= 5.1.11 recorded a
# load-time dependency on 'libtbb.so.2'; without this, they fail to load after
# an upgrade with "libtbb.so.2: cannot open shared object file".
versionBundledTbbLibraries <- function(tbbDest) {

   # downstream binaries look for exactly '.so.2', matching the SONAME suffix
   # the old TBB build derived from TBB_COMPATIBLE_INTERFACE_VERSION
   suffix <- "2"

   libs <- list.files(tbbDest, pattern = "^libtbb.*\\.so$", full.names = TRUE)
   for (lib in libs)
      versionBundledTbbLibrary(lib, paste0(lib, ".", suffix))

}

# Version a single bundled TBB library. Failing to produce the versioned
# layout is an error: a partial or silently-skipped layout would only
# resurface later as load failures in downstream binaries, so fail the
# install loudly instead.
versionBundledTbbLibrary <- function(lib, versioned) {

   # leave symlinks (i.e. an already-versioned layout) untouched; only real,
   # unversioned libraries need renaming
   if (nzchar(Sys.readlink(lib)))
      return(invisible(FALSE))

   # only version actual ELF libraries; this leaves linker scripts alone
   # (in old-style layouts, 'libtbb.so' is an INPUT() script and the real
   # library already sits at 'libtbb.so.2'), while still replacing a stale
   # 'libtbb.so.2' left behind by a previous installation
   if (!isElfFile(lib))
      return(invisible(FALSE))

   fmt <- "** versioning tbb library '%s' -> '%s'"
   msg <- sprintf(fmt, basename(lib), basename(versioned))
   writeLines(msg)

   # 'libtbb.so' -> 'libtbb.so.2'
   if (!isTRUE(file.rename(lib, versioned))) {
      fmt <- "couldn't rename '%s' to '%s'"
      stop(sprintf(fmt, lib, versioned))
   }

   # re-create 'libtbb.so' as a relative symlink pointing back at the
   # versioned library
   linked <- tryCatch(
      file.symlink(basename(versioned), lib),
      warning = function(w) FALSE
   )
   if (isTRUE(linked))
      return(invisible(TRUE))

   # if the symlink couldn't be created (e.g. a filesystem without symlink
   # support), fall back to a plain copy so that 'libtbb.so' still exists.
   # the library has already been renamed at this point, so a failed copy
   # would leave no 'libtbb.so' at all; fail loudly rather than complete a
   # broken install
   writeLines("** couldn't create symlink; copying instead")
   copied <- tryCatch(
      file.copy(versioned, lib, overwrite = TRUE),
      warning = function(w) FALSE
   )
   if (!isTRUE(copied)) {
      fmt <- "couldn't copy '%s' to '%s'"
      stop(sprintf(fmt, versioned, lib))
   }

   invisible(TRUE)

}

isElfFile <- function(path) {
   header <- tryCatch(
      readBin(path, "raw", n = 4L),
      condition = function(cnd) raw()
   )
   identical(header, charToRaw("\x7fELF"))
}

# Report which TBB libraries are about to be installed, and from where.
# Stale or unexpected libraries copied here have historically been a
# subtle source of load failures in downstream packages, so make the
# provenance easy to spot in installation logs.
logTbbLibraries <- function(tbbLibs, source) {
   if (length(tbbLibs)) {
      fmt <- "** copying tbb runtime libraries from '%s' [%s]"
      writeLines(sprintf(fmt, source, paste(basename(tbbLibs), collapse = ", ")))
   } else {
      writeLines(sprintf("** no tbb runtime libraries found in '%s'", source))
   }
}

useTbbPreamble <- function(tbbInc) {

   writeLines(sprintf("** copying tbb headers from '%s'", tbbInc))
   dir.create("../inst/include", recursive = TRUE, showWarnings = FALSE)
   for (suffix in c("oneapi", "serial", "tbb")) {
      tbbPath <- file.path(tbbInc, suffix)
      if (file.exists(tbbPath)) {
         file.copy(tbbPath, "../inst/include", recursive = TRUE)
      }
   }

   invisible(patchTbbMachineHeader("../inst/include/oneapi/tbb/detail/_machine.h"))

}

# Guard the '#include <intrin.h>' in TBB's _machine.h against GCC's
# <cpuid.h> macro on mingw. The headers we ship may come from Rtools
# rather than from the bundled copy of oneTBB, so the guard must be
# applied to the copied headers, not just the bundled sources.
patchTbbMachineHeader <- function(path) {

   if (!file.exists(path)) {
      writeLines(sprintf("** no tbb header at '%s'; skipping mingw cpuid guard", path))
      return(invisible())
   }

   contents <- readLines(path)
   if (any(grepl("push_macro", contents, fixed = TRUE))) {
      writeLines(sprintf("** mingw cpuid guard already present in '%s'", path))
      return(invisible())
   }

   index <- which(contents == "#include <intrin.h>")
   if (length(index) != 1L) {
      fmt <- paste(
         "expected exactly one '#include <intrin.h>' line in '%s', but found %i;",
         "the mingw cpuid guard was not applied, and mingw builds using these",
         "headers may fail -- see patches/mingw_cpuid.diff"
      )
      warning(sprintf(fmt, path, length(index)))
      return(invisible())
   }

   replacement <- c(
      "// GCC's <cpuid.h> defines a function-like '__cpuid' macro that mangles the",
      "// __cpuid() declarations in mingw's <intrin.h>. Hide the macro while",
      "// including <intrin.h> so the two headers can coexist in any order.",
      "#if defined(__MINGW32__) && defined(__cpuid)",
      "#pragma push_macro(\"__cpuid\")",
      "#undef __cpuid",
      "#include <intrin.h>",
      "#pragma pop_macro(\"__cpuid\")",
      "#else",
      "#include <intrin.h>",
      "#endif"
   )

   contents <- append(contents[-index], replacement, after = index - 1L)
   writeLines(contents, path)
   writeLines(sprintf("** applied mingw cpuid guard to '%s'", path))

}

useSystemTbb <- function(tbbLib, tbbInc) {
   useTbbPreamble(tbbInc)
}

useBundledTbb <- function() {

   useTbbPreamble("tbb/include")
   dir.create("tbb/build-tbb", showWarnings = FALSE)

   cmake <- Sys.getenv("CMAKE", unset = "cmake")
   buildType <- Sys.getenv("CMAKE_BUILD_TYPE", unset = "Release")
   verbose <- Sys.getenv("VERBOSE", unset = "0")

   # pull any leading compiler launcher (e.g. ccache) out of CC / CXX before
   # splitting, so it can be forwarded to CMake the way CMake expects it (see
   # extractCompilerLauncher); otherwise ccache would be treated as the
   # compiler itself, breaking CMake's compiler / assembler probes
   ccLauncher  <- extractCompilerLauncher("CC")
   cxxLauncher <- extractCompilerLauncher("CXX")

   splitCompilerVar("CC", "CFLAGS")
   splitCompilerVar("CXX", "CXXFLAGS")

   prependFlags("CPPFLAGS", "CFLAGS")
   prependFlags("CPPFLAGS", "CXXFLAGS")

   # the ucontext APIs (getcontext, swapcontext, ...) are deprecated on macOS,
   # so use the threads-based coroutine implementation for resumable tasks
   if (Sys.info()[["sysname"]] == "Darwin") {
      flags <- c(Sys.getenv("CXXFLAGS"), "-D__TBB_RESUMABLE_TASKS_USE_THREADS=1")
      setenv("CXXFLAGS", flags[nzchar(flags)])
   }

   cmakeFlags <- c(
      forwardEnvVar("CC", "CMAKE_C_COMPILER"),
      forwardEnvVar("CXX", "CMAKE_CXX_COMPILER"),
      if (!is.na(ccLauncher))
         sprintf("-DCMAKE_C_COMPILER_LAUNCHER=%s", ccLauncher),
      if (!is.na(cxxLauncher))
         sprintf("-DCMAKE_CXX_COMPILER_LAUNCHER=%s", cxxLauncher),
      forwardEnvVar("CFLAGS", "CMAKE_C_FLAGS"),
      forwardEnvVar("CXXFLAGS", "CMAKE_CXX_FLAGS"),
      forwardEnvVar("CMAKE_BUILD_TYPE", "CMAKE_BUILD_TYPE"),
      # tbbbind requires hwloc, and hwloc's pkg-config file doesn't advertise
      # the macOS frameworks needed when linking it statically; RcppParallel
      # doesn't use TBB's NUMA APIs, so skip tbbbind altogether
      "-DTBB_DISABLE_HWLOC_AUTOMATIC_SEARCH=1",
      "-DTBB_TEST=0",
      "-DTBB_EXAMPLES=0",
      "-DTBB_STRICT=0",
      ".."
   )

   if (R.version$os == "emscripten") {
      cmakeFlags <- c(
         "-DEMSCRIPTEN=1",
         "-DTBBMALLOC_BUILD=0",
         "-DBUILD_SHARED_LIBS=0",
         cmakeFlags
      )
   }

   # on Windows the generator has to be named explicitly, as cmake otherwise
   # prefers a Visual Studio generator when one happens to be installed. TBB is
   # built shared here, as on every other platform: upstream does not support
   # static builds ("highly discouraged", per its own configure-time warning),
   # and a shared library is what lets RcppParallel and downstream packages
   # share one runtime rather than each linking a private copy
   if (.Platform$OS.type == "windows") {
      cmakeFlags <- c(
         "-G", "MSYS Makefiles",
         cmakeFlags
      )
   }

   writeLines("*** configuring tbb")
   owd <- setwd("tbb/build-tbb")
   output <- system2(cmake, shQuote(cmakeFlags), stdout = TRUE, stderr = TRUE)
   status <- attr(output, "status")
   if (is.numeric(status) && status != 0L) {
      writeLines(output)
      stop("error configuring tbb (status code ", status, ")")
   } else if (!identical(verbose, "0")) {
      writeLines(output)
   }
   setwd(owd)

   if (!identical(verbose, "0")) {
      writeLines("*** dumping CMakeCache.txt")
      writeLines(readLines("tbb/build-tbb/CMakeCache.txt"))
   }

   writeLines("*** building tbb")
   owd <- setwd("tbb/build-tbb")
   output <- system2(cmake, c("--build", ".", "--config", "release"), stdout = TRUE, stderr = TRUE)
   status <- attr(output, "status")
   if (is.numeric(status) && status != 0L) {
      writeLines(output)
      stop("error building tbb (status code ", status, ")")
   } else if (!identical(verbose, "0")) {
      writeLines(output)
   }
   setwd(owd)

   # on wasm TBB is built as a static library, so collect the archives; on
   # Windows collect the DLLs together with their import libraries, so that
   # linking RcppParallel against them below can go through 'libtbb.dll.a'
   # rather than relying on the linker accepting the DLL directly
   shlibPattern <- if (R.version$os == "emscripten") {
      "^libtbb.*\\.a$"
   } else if (.Platform$OS.type == "windows") {
      "^(lib)?tbb.*\\.dll(\\.a)?$"
   } else if (Sys.info()[["sysname"]] == "Darwin") {
      "^libtbb.*\\.dylib$"
   } else {
      "^libtbb.*\\.so.*$"
   }

   tbbFiles <- list.files(
      file.path(getwd(), "tbb/build-tbb"),
      pattern = shlibPattern,
      recursive = TRUE,
      full.names = TRUE
   )

   # clear any artifacts from prior builds, so that we only ship
   # the libraries produced by the build above
   unlink("tbb/build/lib_release", recursive = TRUE)

   dir.create("tbb/build/lib_release", recursive = TRUE, showWarnings = FALSE)
   file.copy(tbbFiles, "tbb/build/lib_release", overwrite = TRUE)
   unlink("tbb/build-tbb", recursive = TRUE)
   writeLines("*** finished building tbb")

}

getenv <- function(key, unset = "") {
   Sys.getenv(key, unset = unset)
}


setenv <- function(key, value) {
   args <- list(paste(value, collapse = " "))
   names(args) <- key
   do.call(Sys.setenv, args)
}


# Compiler launchers such as ccache are commonly injected by prefixing the
# compiler (e.g. CXX='ccache g++'). CMake models these via the separate
# CMAKE_<LANG>_COMPILER_LAUNCHER variable rather than as part of the compiler
# command, so detect a leading launcher, strip it from the compiler variable,
# and return it for forwarding. Returns NA when no launcher is present.
extractCompilerLauncher <- function(compilerVar) {

   compiler <- Sys.getenv(compilerVar, unset = NA)
   if (is.na(compiler))
      return(NA_character_)

   tokens <- scan(text = compiler, what = character(), quiet = TRUE)
   if (length(tokens) == 0L)
      return(NA_character_)

   launcher <- tokens[[1L]]
   name <- sub("[.]exe$", "", basename(launcher), ignore.case = TRUE)
   if (!name %in% c("ccache", "sccache"))
      return(NA_character_)

   # drop the launcher, leaving the real compiler (and any flags) behind
   setenv(compilerVar, tokens[-1L])
   launcher

}


# CMake doesn't support flags specified directly as part of the compiler
# definition, so manually split it here.
splitCompilerVar <- function(compilerVar, flagsVar) {

   compiler <- Sys.getenv(compilerVar, unset = NA)
   if (is.na(compiler))
      return(FALSE)

   tokens <- scan(text = compiler, what = character(), quiet = TRUE)
   if (length(tokens) == 0L)
      return(FALSE)

   # always re-set the compiler from the parsed tokens, even when there are
   # no trailing flags: scan() strips surrounding whitespace, so this also
   # normalizes values like ' g++' (produced when e.g. '$(CCACHE) g++'
   # expands with an empty CCACHE), which CMake would otherwise reject
   setenv(compilerVar, tokens[[1L]])

   oldFlags <- Sys.getenv(flagsVar)
   newFlags <- c(tokens[-1L], oldFlags)
   setenv(flagsVar, newFlags[nzchar(newFlags)])

   TRUE

}


# Given an environment variable like 'CC', forward that to CMake
# via the corresponding CMAKE_C_COMPILER flag.
forwardEnvVar <- function(envVar, cmakeVar) {
   envVal <- Sys.getenv(envVar, unset = NA)
   if (!is.na(envVal)) {
      sprintf("-D%s=%s", cmakeVar, envVal)
   }
}

prependFlags <- function(prependFlags, toFlags) {

   prependVal <- Sys.getenv(prependFlags, unset = NA)
   if (is.na(prependVal))
      return(FALSE)

   oldVal <- Sys.getenv(toFlags, unset = NA)
   if (is.na(oldVal)) {
      setenv(toFlags, prependVal)
   } else {
      setenv(toFlags, paste(prependVal, oldVal))
   }

   TRUE

}

# Main ----

tbbLib <- Sys.getenv("TBB_LIB")
tbbInc <- Sys.getenv("TBB_INC")

args <- commandArgs(trailingOnly = TRUE)
if (identical(args, "build")) {
   if (nzchar(tbbLib) && nzchar(tbbInc)) {
      useSystemTbb(tbbLib, tbbInc)
   } else {
      useBundledTbb()
   }
} else {

   # prefer the configure-detected TBB_LIB when the environment variable is
   # unset; otherwise a TBB configured via TBB_ROOT (which sets TBB_LIB only in
   # the generated tbb-autodetected.R) would wrongly take the bundled-TBB
   # branch below, and ship any stale artifacts in tbb/build/lib_release
   source("../R/tbb-autodetected.R")
   if (!nzchar(tbbLib))
      tbbLib <- TBB_LIB

   .install.libs(tbbLib)

}