Cache R CMD config values for the session

Author: t-kalinowski

NEWS.md

@@ -1,5 +1,9 @@
 # quickr (development version)
 
+* Repeated `quick()` compilations now reuse successful `R CMD config` results
+  for the rest of the R session. Restart R after changing the compiler or
+  Makevars configuration.
+
 # quickr 0.3.0
 
 This release adds major new support for linear algebra, local functions,

R/aaa-utils.R

@@ -54,29 +54,69 @@ quickr_r_cmd <- function(
   r_cmd
 }
 
+quickr_compiler_probe_cache <- new.env(parent = emptyenv())
+
+quickr_cached_r_cmd_config_value <- function(
+  name,
+  cache = quickr_compiler_probe_cache
+) {
+  stopifnot(is_string(name), is.environment(cache))
+
+  # Compiler configuration is fixed for the R session. Restart R after
+  # changing the toolchain or its configuration files.
+  cache_key <- paste("r_cmd_config", name, sep = "\r")
+  if (exists(cache_key, envir = cache, inherits = FALSE)) {
+    return(get(cache_key, envir = cache, inherits = FALSE))
+  }
+
+  probe <- quickr_r_cmd_config_probe(name)
+  if (isTRUE(probe$ok)) {
+    assign(cache_key, probe$value, envir = cache)
+  }
+  probe$value
+}
+
 quickr_r_cmd_config_value <- function(
   name,
   r_cmd = quickr_r_cmd(),
   system2 = base::system2
 ) {
+  quickr_r_cmd_config_probe(
+    name = name,
+    r_cmd = r_cmd,
+    system2 = system2
+  )$value
+}
+
+quickr_r_cmd_config_probe <- function(
+  name,
+  r_cmd = quickr_r_cmd(),
+  system2 = base::system2
+) {
+  stopifnot(is_string(name), is_string(r_cmd), is.function(system2))
+
   out <- tryCatch(
     suppressWarnings(system2(
       r_cmd,
       c("CMD", "config", name),
       stdout = TRUE,
       stderr = FALSE
     )),
-    error = function(e) character()
+    error = function(e) structure(character(), status = 1L)
   )
   status <- attr(out, "status")
   if (!is.null(status)) {
-    return("")
+    return(list(value = "", ok = FALSE))
   }
   value <- trimws(paste(out, collapse = " "))
-  if (!nzchar(value) || grepl("^ERROR:", value)) {
-    return("")
+  if (!nzchar(value)) {
+    return(list(value = "", ok = TRUE))
   }
-  value
+  if (grepl("^ERROR:", value)) {
+    return(list(value = "", ok = FALSE))
+  }
+
+  list(value = value, ok = TRUE)
 }
 
 

R/compiler.R

@@ -165,7 +165,7 @@ quickr_prefer_flang <- function(sysname = Sys.info()[["sysname"]]) {
 }
 
 quickr_default_fortran_makevars_lines <- function(
-  config_value = quickr_r_cmd_config_value
+  config_value = quickr_cached_r_cmd_config_value
 ) {
   fc <- trimws(config_value("FC"))
   if (!nzchar(fc)) {
@@ -191,7 +191,7 @@ quickr_fcompiler_env <- function(
   sysname = Sys.info()[["sysname"]],
   use_openmp = FALSE,
   link_flags = character(),
-  config_value = quickr_r_cmd_config_value
+  config_value = quickr_cached_r_cmd_config_value
 ) {
   stopifnot(is.character(build_dir), length(build_dir) == 1L, nzchar(build_dir))
 

R/parallel.R

@@ -173,25 +173,16 @@ openmp_directives <- function(parallel, private = NULL) {
   )
 }
 
-openmp_config_value <- local({
-  cached <- NULL
-
-  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)
-    }
-    value <- config_value(name)
-    if (!nzchar(value)) {
-      value <- ""
-    }
-    cached[[name]] <<- value
-    value
+openmp_config_value <- function(
+  name,
+  config_value = quickr_cached_r_cmd_config_value
+) {
+  value <- config_value(name)
+  if (!nzchar(value)) {
+    value <- ""
   }
-})
+  value
+}
 
 openmp_fflags <- function() {
   env_flags <- trimws(Sys.getenv("QUICKR_OPENMP_FFLAGS", ""))

R/quick.R

@@ -213,7 +213,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 <- quickr_r_cmd_config_value
+  cfg <- quickr_cached_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]]
@@ -327,7 +327,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 = quickr_r_cmd_config_value,
+  config_value = quickr_cached_r_cmd_config_value,
   which = Sys.which
 ) {
   if (!identical(os_type, "windows")) {

tests/testthat/test-compiler.R

@@ -2,6 +2,35 @@
 
 skip_on_cran()
 
+local_empty_compiler_probe_cache <- function(envir = parent.frame()) {
+  cache <- get0(
+    "quickr_compiler_probe_cache",
+    envir = asNamespace("quickr"),
+    inherits = FALSE
+  )
+  if (is.null(cache)) {
+    return(invisible(NULL))
+  }
+
+  old <- as.list.environment(cache, all.names = TRUE)
+  withr::defer(
+    {
+      entries <- ls(envir = cache, all.names = TRUE)
+      if (length(entries)) {
+        rm(list = entries, envir = cache)
+      }
+      list2env(old, envir = cache)
+    },
+    envir = envir
+  )
+
+  entries <- ls(envir = cache, all.names = TRUE)
+  if (length(entries)) {
+    rm(list = entries, envir = cache)
+  }
+  invisible(NULL)
+}
+
 test_that("quickr_r_cmd_config_value captures only stdout", {
   expect_identical(
     deparse(formals(quickr:::quickr_r_cmd_config_value)$system2),
@@ -49,6 +78,28 @@ test_that("quickr_r_cmd_config_value returns empty on command failure", {
   )
 })
 
+test_that("R CMD config probe distinguishes empty values from errors", {
+  empty_value <- function(...) character()
+  expect_identical(
+    quickr:::quickr_r_cmd_config_probe(
+      "CC",
+      r_cmd = "R",
+      system2 = empty_value
+    ),
+    list(value = "", ok = TRUE)
+  )
+
+  error_value <- function(...) "ERROR: no information for variable 'CC'"
+  expect_identical(
+    quickr:::quickr_r_cmd_config_probe(
+      "CC",
+      r_cmd = "R",
+      system2 = error_value
+    ),
+    list(value = "", ok = FALSE)
+  )
+})
+
 test_that("quickr_flang_path prefers flang-new", {
   which_stub <- function(x) {
     if (x == "flang-new") {
@@ -459,3 +510,67 @@ test_that("compile cleans existing build directories and reports failures", {
   expect_true(dir.exists(build_dir))
   expect_false(file.exists(file.path(build_dir, "stale.txt")))
 })
+
+test_that("quick reuses successful R CMD config probes", {
+  local_empty_compiler_probe_cache()
+  withr::local_options(quickr.fortran_compiler = "gfortran")
+
+  probe <- quickr_r_cmd_config_probe
+  events <- list()
+  local_mocked_bindings(
+    quickr_r_cmd_config_probe = function(name, ...) {
+      result <- probe(name, ...)
+      events[[length(events) + 1L]] <<- list(name = name, ok = result$ok)
+      result
+    },
+    .package = "quickr"
+  )
+
+  fn <- function(x) {
+    declare(type(x = double(1)))
+    x + 1
+  }
+
+  expect_quick_identical(fn, 1)
+  first_events <- events
+  expect_quick_identical(fn, 3)
+
+  successful <- unique(vapply(
+    first_events[vapply(first_events, `[[`, logical(1), "ok")],
+    `[[`,
+    character(1),
+    "name"
+  ))
+  later <- events[seq_along(events) > length(first_events)]
+  later_names <- vapply(later, `[[`, character(1), "name")
+  expect_length(intersect(successful, later_names), 0L)
+})
+
+test_that("quick retries failed R CMD config probes", {
+  local_empty_compiler_probe_cache()
+  withr::local_options(quickr.fortran_compiler = "gfortran")
+
+  probe <- quickr_r_cmd_config_probe
+  blas_calls <- 0L
+  local_mocked_bindings(
+    quickr_r_cmd_config_probe = function(name, ...) {
+      if (identical(name, "BLAS_LIBS")) {
+        blas_calls <<- blas_calls + 1L
+        if (blas_calls == 1L) {
+          return(list(value = "", ok = FALSE))
+        }
+      }
+      probe(name, ...)
+    },
+    .package = "quickr"
+  )
+
+  fn <- function(x) {
+    declare(type(x = double(1)))
+    x + 1
+  }
+
+  expect_quick_identical(fn, 1)
+  expect_quick_identical(fn, 3)
+  expect_identical(blas_calls, 2L)
+})

tests/testthat/test-openmp-utils.R

@@ -39,31 +39,6 @@ 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_config <- cache_env$quickr_r_cmd_config_value
-  withr::defer(cache_env$cached <- old_cache)
-  withr::defer({
-    if (is.null(old_config)) {
-      rm(quickr_r_cmd_config_value, envir = cache_env)
-    } else {
-      cache_env$quickr_r_cmd_config_value <- old_config
-    }
-  })
-  cache_env$cached <- NULL
-
-  calls <- 0
-  cache_env$quickr_r_cmd_config_value <- function(...) {
-    calls <<- calls + 1
-    "value"
-  }
-
-  expect_equal(quickr:::openmp_config_value("QUICKR_TEST_CACHE"), "value")
-  expect_equal(quickr:::openmp_config_value("QUICKR_TEST_CACHE"), "value")
-  expect_equal(calls, 1)
-})
-
 test_that("get_pending_parallel returns NULL for NULL or non-scope", {
   expect_null(quickr:::get_pending_parallel(NULL))
   expect_null(quickr:::get_pending_parallel(list()))