Cache compiler configuration probes

Author: t-kalinowski

R/aaa-utils.R

@@ -54,29 +54,67 @@ 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))
+
+  cached <- get0(name, envir = cache, inherits = FALSE, ifnotfound = NULL)
+  if (is.null(cached)) {
+    probe <- quickr_r_cmd_config_probe(name)
+    cached <- probe$value
+    if (isTRUE(probe$ok)) {
+      assign(name, cached, envir = cache)
+    }
+  }
+
+  cached
+}
+
 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

@@ -15,6 +15,15 @@ quickr_flang_available <- function(
   system2 = base::system2
 ) {
   flang <- quickr_flang_path(which = which)
+  quickr_flang_available_at_path(flang, system2 = system2)
+}
+
+quickr_flang_available_at_path <- function(
+  flang,
+  system2 = base::system2
+) {
+  stopifnot(is_string(flang), is.function(system2))
+
   if (!nzchar(flang)) {
     return(list(path = "", available = FALSE))
   }
@@ -28,6 +37,36 @@ quickr_flang_available <- function(
   list(path = flang, available = TRUE)
 }
 
+quickr_cached_flang_available <- function(
+  which = Sys.which,
+  system2 = base::system2,
+  cache = quickr_compiler_probe_cache
+) {
+  stopifnot(is.function(which), is.function(system2), is.environment(cache))
+
+  flang <- quickr_flang_path(which = which)
+  if (!identical(system2, base::system2)) {
+    return(quickr_flang_available_at_path(flang, system2 = system2))
+  }
+
+  cache_key <- paste("flang_available", flang, sep = "\r")
+  cached <- get0(cache_key, envir = cache, inherits = FALSE, ifnotfound = NULL)
+  if (!is.null(cached)) {
+    fresh <- quickr_flang_available_at_path(flang)
+    if (!isTRUE(fresh$available)) {
+      rm(list = cache_key, envir = cache)
+    }
+    return(fresh)
+  }
+
+  cached <- quickr_flang_available_at_path(flang)
+  if (isTRUE(cached$available)) {
+    assign(cache_key, cached, envir = cache)
+  }
+
+  cached
+}
+
 quickr_flang_state <- local({
   state <- new.env(parent = emptyenv())
   state$auto_disabled <- FALSE
@@ -164,15 +203,15 @@ quickr_prefer_flang <- function(
 
   # Best-effort: on macOS, prefer flang if it is available.
   if (sysname == "Darwin") {
-    info <- quickr_flang_available(which = which, system2 = system2)
+    info <- quickr_cached_flang_available(which = which, system2 = system2)
     return(isTRUE(info$available))
   }
 
   FALSE
 }
 
 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)) {
@@ -200,7 +239,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))
 
@@ -217,7 +256,10 @@ quickr_fcompiler_env <- function(
     system2 = system2
   ))
   if (use_flang) {
-    flang_info <- quickr_flang_available(which = which, system2 = system2)
+    flang_info <- quickr_cached_flang_available(
+      which = which,
+      system2 = system2
+    )
     flang <- flang_info$path
     if (!isTRUE(flang_info$available)) {
       if (isTRUE(explicit_request)) {

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]]
@@ -326,39 +326,47 @@ 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")) {
-    return(invisible(FALSE))
+    return(invisible(character()))
   }
+
+  config_path <- function(value) {
+    value <- trimws(value)
+    if (!nzchar(value)) {
+      return("")
+    }
+    value <- sub("^\"([^\"]+)\".*", "\\1", value)
+    value <- sub("^'([^']+)'.*", "\\1", value)
+    strsplit(value, "\\s+")[[1L]][[1L]]
+  }
+
   dirs <- flags[grepl("^-L", flags)]
   dirs <- sub("^-L", "", dirs)
+  dirs <- vapply(dirs, config_path, character(1))
   dirs <- dirs[nzchar(dirs)]
 
-  bin_siblings <- file.path(dirs, "..", "bin")
+  bin_siblings <- c(
+    file.path(dirs, "..", "bin"),
+    file.path(dirs, "..", "..", "bin")
+  )
 
+  config_binpref <- config_path(config_value("BINPREF"))
+  if (nzchar(config_binpref) && !dir.exists(config_binpref)) {
+    config_binpref <- dirname(config_binpref)
+  }
   config_values <- c(
-    config_value("BINPREF"),
     config_value("FC"),
     config_value("F77"),
     config_value("CC"),
     config_value("CXX")
   )
-  config_paths <- vapply(
-    config_values,
-    function(value) {
-      value <- trimws(value)
-      if (!nzchar(value)) {
-        return("")
-      }
-      value <- sub("^\"([^\"]+)\".*", "\\1", value)
-      value <- sub("^'([^']+)'.*", "\\1", value)
-      strsplit(value, "\\s+")[[1L]][[1L]]
-    },
-    character(1)
-  )
-  config_bins <- unique(dirname(config_paths[nzchar(config_paths)]))
+  config_paths <- vapply(config_values, config_path, character(1))
+  config_bins <- dirname(config_paths[nzchar(config_paths)])
+  config_bins <- config_bins[nzchar(config_bins) & config_bins != "."]
+  config_bins <- unique(c(config_binpref, config_bins))
 
   r_bin <- R.home("bin")
   r_bin_x64 <- file.path(r_bin, "x64")
@@ -373,6 +381,16 @@ quickr_windows_add_dll_paths <- function(
     "RTOOLS_HOME"
   ))
   rtools_roots <- rtools_roots[nzchar(rtools_roots)]
+  link_dirs <- gsub("\\", "/", dirs, fixed = TRUE)
+  rtools_link_roots <- sub(
+    "/(?:x86_64|aarch64)-w64-mingw32(?:\\.static(?:\\.posix)?)?/.*$",
+    "",
+    link_dirs
+  )
+  rtools_link_roots <- rtools_link_roots[
+    nzchar(rtools_link_roots) & rtools_link_roots != link_dirs
+  ]
+  rtools_roots <- unique(c(rtools_roots, rtools_link_roots))
   rtools_bins <- unique(c(
     file.path(rtools_roots, "usr", "bin"),
     file.path(rtools_roots, "mingw64", "bin"),
@@ -399,8 +417,9 @@ quickr_windows_add_dll_paths <- function(
   dirs <- dirs[nzchar(dirs)]
   dirs <- dirs[dir.exists(dirs)]
   if (!length(dirs)) {
-    return(invisible(FALSE))
+    return(invisible(character()))
   }
+  dirs <- normalizePath(dirs, winslash = "\\", mustWork = FALSE)
 
   path <- Sys.getenv("PATH", unset = "")
   existing <- strsplit(path, ";", fixed = TRUE)[[1]]
@@ -414,10 +433,9 @@ quickr_windows_add_dll_paths <- function(
   to_add <- dirs[!dirs_norm %in% existing_norm]
   if (length(to_add)) {
     Sys.setenv(PATH = paste(c(to_add, existing), collapse = ";"))
-    return(invisible(TRUE))
   }
 
-  invisible(FALSE)
+  invisible(dirs)
 }
 
 

tests/testthat/test-compiler-cache.R

@@ -0,0 +1,74 @@
+skip_on_cran()
+
+test_that("quickr_cached_r_cmd_config_value retries failed lookups", {
+  cache <- new.env(parent = emptyenv())
+  calls <- 0L
+  system2_stub <- function(command, args, stdout = "", stderr = "", ...) {
+    calls <<- calls + 1L
+    if (calls == 1L) {
+      return(structure(" value ", status = 1L))
+    }
+    "gfortran"
+  }
+
+  local_mocked_bindings(system2 = system2_stub, .package = "base")
+
+  expect_identical(quickr_cached_r_cmd_config_value("FC", cache = cache), "")
+  expect_identical(
+    quickr_cached_r_cmd_config_value("FC", cache = cache),
+    "gfortran"
+  )
+  expect_identical(
+    quickr_cached_r_cmd_config_value("FC", cache = cache),
+    "gfortran"
+  )
+  expect_equal(calls, 2L)
+})
+
+test_that("quickr_cached_flang_available retries failed probes", {
+  cache <- new.env(parent = emptyenv())
+  calls <- 0L
+  which_stub <- function(x) if (x == "flang-new") "/tmp/flang-new" else ""
+  system2_stub <- function(...) {
+    calls <<- calls + 1L
+    if (calls == 1L) {
+      return(structure("error", status = 1L))
+    }
+    "flang version"
+  }
+
+  local_mocked_bindings(system2 = system2_stub, .package = "base")
+
+  result <- quickr_cached_flang_available(which = which_stub, cache = cache)
+  expect_identical(result$path, "/tmp/flang-new")
+  expect_false(result$available)
+
+  result <- quickr_cached_flang_available(which = which_stub, cache = cache)
+  expect_identical(result$path, "/tmp/flang-new")
+  expect_true(result$available)
+  expect_equal(calls, 2L)
+})
+
+test_that("quickr_cached_flang_available revalidates successful probes", {
+  cache <- new.env(parent = emptyenv())
+  calls <- 0L
+  which_stub <- function(x) if (x == "flang-new") "/tmp/flang-new" else ""
+  system2_stub <- function(...) {
+    calls <<- calls + 1L
+    if (calls == 1L) {
+      return("flang version")
+    }
+    structure("error", status = 1L)
+  }
+
+  local_mocked_bindings(system2 = system2_stub, .package = "base")
+
+  result <- quickr_cached_flang_available(which = which_stub, cache = cache)
+  expect_identical(result$path, "/tmp/flang-new")
+  expect_true(result$available)
+
+  result <- quickr_cached_flang_available(which = which_stub, cache = cache)
+  expect_identical(result$path, "/tmp/flang-new")
+  expect_false(result$available)
+  expect_equal(calls, 2L)
+})

tests/testthat/test-compiler.R

@@ -131,6 +131,11 @@ test_that("quickr_fortran_compiler_option validates values", {
 })
 
 test_that("quickr_fcompiler_env writes Makevars when flang is usable", {
+  rm(
+    list = ls(envir = quickr_compiler_probe_cache, all.names = TRUE),
+    envir = quickr_compiler_probe_cache
+  )
+
   temp <- withr::local_tempdir()
   prefix <- file.path(temp, "flang")
   dir.create(file.path(prefix, "bin"), recursive = TRUE)