Simplify R CMD config lookups

Author: t-kalinowski

R/aaa-utils.R

@@ -6,6 +6,43 @@ NULL
 
 `%||%` <- function(x, y) if (is.null(x)) y else x
 
+quickr_r_cmd <- function(
+  os_type = .Platform$OS.type,
+  r_home = R.home,
+  file_exists = file.exists
+) {
+  r_cmd <- r_home("bin/R")
+  if (identical(os_type, "windows") && !file_exists(r_cmd)) {
+    r_cmd <- paste0(r_cmd, ".exe")
+  }
+  r_cmd
+}
+
+quickr_r_cmd_config_value <- function(
+  name,
+  r_cmd = quickr_r_cmd(),
+  system2 = system2
+) {
+  out <- tryCatch(
+    suppressWarnings(system2(
+      r_cmd,
+      c("CMD", "config", name),
+      stdout = TRUE,
+      stderr = TRUE
+    )),
+    error = function(e) character()
+  )
+  status <- attr(out, "status")
+  if (!is.null(status)) {
+    return("")
+  }
+  value <- trimws(paste(out, collapse = " "))
+  if (!nzchar(value) || grepl("^ERROR:", value)) {
+    return("")
+  }
+  value
+}
+
 
 # @export
 # This will be exported by S7 next release.

R/parallel.R

@@ -138,37 +138,17 @@ openmp_directives <- function(parallel, private = NULL) {
 openmp_config_value <- local({
   cached <- NULL
 
-  function(name) {
+  function(name, config_value = quickr_r_cmd_config_value) {
     if (is.null(cached)) {
       cached <<- list()
     }
     cached_value <- cached[[name]]
     if (!is.null(cached_value)) {
       return(cached_value)
     }
-
-    r_cmd <- R.home("bin/R")
-    if (identical(.Platform$OS.type, "windows") && !file.exists(r_cmd)) {
-      r_cmd <- paste0(r_cmd, ".exe")
-    }
-    out <- tryCatch(
-      suppressWarnings(system2(
-        r_cmd,
-        c("CMD", "config", name),
-        stdout = TRUE,
-        stderr = TRUE
-      )),
-      error = function(e) character()
-    )
-    status <- attr(out, "status")
-    if (!is.null(status)) {
-      cached[[name]] <<- ""
-      return("")
-    }
-    value <- trimws(paste(out, collapse = " "))
-    if (!nzchar(value) || grepl("^ERROR:", value)) {
-      cached[[name]] <<- ""
-      return("")
+    value <- config_value(name)
+    if (!nzchar(value)) {
+      value <- ""
     }
     cached[[name]] <<- value
     value

R/quick.R

@@ -210,25 +210,7 @@ compile <- function(fsub, build_dir = tempfile(paste0(fsub@name, "-build-"))) {
 
   # Link against the same BLAS/LAPACK/Fortran libs as the running R
   # to support generated calls to vendor BLAS (e.g., dgemm, dgesv).
-  cfg <- function(var) {
-    r_cmd <- R.home("bin/R")
-    if (identical(.Platform$OS.type, "windows") && !file.exists(r_cmd)) {
-      r_cmd <- paste0(r_cmd, ".exe")
-    }
-    tryCatch(
-      {
-        out <- system2(
-          r_cmd,
-          c("CMD", "config", var),
-          stdout = TRUE,
-          stderr = FALSE
-        )
-        paste(out, collapse = " ")
-      },
-      error = function(e) ""
-    )
-  }
-
+  cfg <- quickr_r_cmd_config_value
   BLAS_LIBS <- strsplit(cfg("BLAS_LIBS"), "[[:space:]]+")[[1]]
   LAPACK_LIBS <- strsplit(cfg("LAPACK_LIBS"), "[[:space:]]+")[[1]]
   FLIBS <- strsplit(cfg("FLIBS"), "[[:space:]]+")[[1]]
@@ -237,8 +219,8 @@ compile <- function(fsub, build_dir = tempfile(paste0(fsub@name, "-build-"))) {
   FLIBS <- FLIBS[nzchar(FLIBS)]
   link_flags <- c(LAPACK_LIBS, BLAS_LIBS, FLIBS)
 
+  use_openmp <- isTRUE(attr(fsub@scope, "uses_openmp", exact = TRUE))
   suppressWarnings({
-    use_openmp <- isTRUE(attr(fsub@scope, "uses_openmp", exact = TRUE))
     env <- quickr_fcompiler_env(
       build_dir = build_dir,
       use_openmp = use_openmp,
@@ -261,42 +243,37 @@ compile <- function(fsub, build_dir = tempfile(paste0(fsub@name, "-build-"))) {
       stderr = TRUE,
       env = env
     )
-    if (!is.null(attr(result, "status")) && length(env)) {
-      if (use_openmp) {
-        attr(result, "quickr_openmp_failed") <- TRUE
+    if (!is.null(attr(result, "status")) && length(env) && !use_openmp) {
+      result2 <- system2(
+        R.home("bin/R"),
+        r_args_libs,
+        stdout = TRUE,
+        stderr = TRUE
+      )
+      if (is.null(attr(result2, "status"))) {
+        result <- result2
       } else {
-        result2 <- system2(
-          R.home("bin/R"),
-          r_args_libs,
-          stdout = TRUE,
-          stderr = TRUE
+        # Prefer to show the flang attempt first, then the fallback attempt.
+        result <- c(
+          "--- flang attempt ---",
+          result,
+          "",
+          "--- fallback attempt ---",
+          result2
         )
-        if (is.null(attr(result2, "status"))) {
-          result <- result2
-        } else {
-          # Prefer to show the flang attempt first, then the fallback attempt.
-          result <- c(
-            "--- flang attempt ---",
-            result,
-            "",
-            "--- fallback attempt ---",
-            result2
-          )
-          attr(result, "status") <- attr(result2, "status")
-        }
+        attr(result, "status") <- attr(result2, "status")
       }
     }
   })
 
   status <- attr(result, "status")
-  openmp_failed <- isTRUE(attr(result, "quickr_openmp_failed"))
   if (!is.null(status)) {
     # Adjust the compiler error so RStudio console formatter doesn't mangle
     # the actual error message https://github.com/rstudio/rstudio/issues/16365
     result <- gsub("Error: ", "Compiler Error: ", result, fixed = TRUE)
     writeLines(result, stderr())
     cat("---\nCompiler exit status:", status, "\n", file = stderr())
-    if (openmp_failed) {
+    if (use_openmp) {
       openmp_abort(
         paste(
           "OpenMP was requested but compilation with OpenMP flags failed.",
@@ -340,7 +317,7 @@ compile <- function(fsub, build_dir = tempfile(paste0(fsub@name, "-build-"))) {
 quickr_windows_add_dll_paths <- function(
   flags,
   os_type = .Platform$OS.type,
-  config_value = openmp_config_value,
+  config_value = quickr_r_cmd_config_value,
   which = Sys.which
 ) {
   if (!identical(os_type, "windows")) {

tests/testthat/helper.R

@@ -75,17 +75,23 @@ openmp_supported_or_skip <- local({
     skip_on_cran()
     skip_if_not_installed("pkgload")
     if (is.null(supported)) {
-      supported <<- {
-        quick(function(x) {
-          declare(type(x = double(1)))
-          declare(parallel())
-          for (i in seq_len(1L)) {
-            x[i] <- x[i] + 1
-          }
-          x
-        })
-        TRUE
-      }
+      supported <<- tryCatch(
+        {
+          quick(function(x) {
+            declare(type(x = double(1)))
+            declare(parallel())
+            for (i in seq_len(1L)) {
+              x[i] <- x[i] + 1
+            }
+            x
+          })
+          TRUE
+        },
+        quickr_openmp_unavailable = function(e) FALSE
+      )
+    }
+    if (!isTRUE(supported)) {
+      skip("OpenMP toolchain not available")
     }
   }
 })

tests/testthat/test-compiler.R

@@ -75,67 +75,6 @@ test_that("quickr_fcompiler_env writes Makevars when flang is usable", {
   expect_true(file.exists(sub("R_MAKEVARS_USER=", "", env, fixed = TRUE)))
 })
 
-test_that("quickr_windows_add_dll_paths updates PATH for Windows-style runs", {
-  temp <- withr::local_tempdir()
-  lib_dir <- file.path(temp, "lib")
-  bin_dir <- file.path(temp, "bin")
-  dir.create(lib_dir, recursive = TRUE)
-  dir.create(bin_dir, recursive = TRUE)
-
-  withr::local_envvar(PATH = "C:\\Existing")
-  expect_true(quickr:::quickr_windows_add_dll_paths(
-    flags = paste0("-L", lib_dir),
-    os_type = "windows",
-    config_value = function(...) "",
-    which = function(...) ""
-  ))
-
-  path <- strsplit(Sys.getenv("PATH"), ";", fixed = TRUE)[[1]]
-  path_norm <- tolower(normalizePath(path, winslash = "\\", mustWork = FALSE))
-  lib_norm <- tolower(normalizePath(lib_dir, winslash = "\\", mustWork = FALSE))
-  bin_norm <- tolower(normalizePath(bin_dir, winslash = "\\", mustWork = FALSE))
-
-  expect_true(lib_norm %in% path_norm)
-  expect_true(bin_norm %in% path_norm)
-  expect_false(quickr:::quickr_windows_add_dll_paths(
-    flags = paste0("-L", lib_dir),
-    os_type = "windows",
-    config_value = function(...) "",
-    which = function(...) ""
-  ))
-})
-
-test_that("quickr_windows_add_dll_paths is a no-op outside Windows", {
-  withr::local_envvar(PATH = "C:\\Existing")
-  expect_false(quickr:::quickr_windows_add_dll_paths(
-    flags = "-Lfoo",
-    os_type = "unix",
-    config_value = function(...) "",
-    which = function(...) ""
-  ))
-})
-
-test_that("quickr_windows_add_dll_paths uses BINPREF from config", {
-  temp <- withr::local_tempdir()
-  bin_dir <- file.path(temp, "bin")
-  dir.create(bin_dir, recursive = TRUE)
-  binpref <- file.path(bin_dir, "x86_64-w64-mingw32-")
-
-  withr::local_envvar(PATH = "C:\\Existing")
-  expect_true(quickr:::quickr_windows_add_dll_paths(
-    flags = character(),
-    os_type = "windows",
-    config_value = function(key) if (key == "BINPREF") binpref else "",
-    which = function(...) ""
-  ))
-
-  path <- strsplit(Sys.getenv("PATH"), ";", fixed = TRUE)[[1]]
-  path_norm <- tolower(normalizePath(path, winslash = "\\", mustWork = FALSE))
-  bin_norm <- tolower(normalizePath(bin_dir, winslash = "\\", mustWork = FALSE))
-
-  expect_true(bin_norm %in% path_norm)
-})
-
 test_that("compile cleans existing build directories and reports failures", {
   fsub <- r2f(function(x) {
     declare(type(x = double(1)))

tests/testthat/test-openmp-utils.R

@@ -40,19 +40,19 @@ test_that("openmp_makevars_lines errors when linker flags are missing", {
 test_that("openmp_config_value caches toolchain lookups", {
   cache_env <- environment(quickr:::openmp_config_value)
   old_cache <- cache_env$cached
-  old_system2 <- cache_env$system2
+  old_config <- cache_env$quickr_r_cmd_config_value
   withr::defer(cache_env$cached <- old_cache)
   withr::defer({
-    if (is.null(old_system2)) {
-      rm(system2, envir = cache_env)
+    if (is.null(old_config)) {
+      rm(quickr_r_cmd_config_value, envir = cache_env)
     } else {
-      cache_env$system2 <- old_system2
+      cache_env$quickr_r_cmd_config_value <- old_config
     }
   })
   cache_env$cached <- NULL
 
   calls <- 0
-  cache_env$system2 <- function(...) {
+  cache_env$quickr_r_cmd_config_value <- function(...) {
     calls <<- calls + 1
     "value"
   }