tests/testthat/test-visualization-fork-safety.R

In artma: Automatic Replication Tools for Meta-Analysis

box::use(
  testthat[
    expect_equal,
    expect_error,
    expect_false,
    expect_null,
    expect_true,
    skip_if,
    skip_if_not_installed,
    test_that
  ]
)

can_fork <- function() {
  cores <- tryCatch(parallel::detectCores(), error = function(err) NA_integer_)
  !identical(.Platform$OS.type, "windows") && is.numeric(cores) && !is.na(cores) && cores >= 2L
}

# Pixel dimensions straight out of the PNG header: an 8-byte signature, then the
# IHDR chunk whose payload opens with the width and height as big-endian 32-bit
# integers. Reading them here keeps the assertions dependency-free.
png_dim <- function(path) {
  con <- file(path, open = "rb")
  on.exit(close(con), add = TRUE)
  header <- readBin(con, "raw", n = 24L)
  if (length(header) < 24L) {
    return(c(NA_integer_, NA_integer_))
  }
  as.integer(c(
    sum(as.integer(header[17:20]) * 256^(3:0)),
    sum(as.integer(header[21:24]) * 256^(3:0))
  ))
}

# The suite renders PNGs on grDevices::png() (see setup.R), but a forked child
# must not: with recent pango, a child that lays out text through cairo waits on
# the parent's font-matching thread, which fork() does not copy, and hangs. The
# children here draw on ragg instead, the production default on this path. The
# parent never draws with ragg, so each child's font cache starts empty and
# stays far below the 32 entries that trip AddressSanitizer.
local_ragg_in_forks <- function(.local_envir = parent.frame()) {
  box::use(artma / visualization / export[BASE_PNG_DEVICE_OPTION])
  withr::local_options(
    stats::setNames(list(FALSE), BASE_PNG_DEVICE_OPTION),
    .local_envir = .local_envir
  )
}

# The regression this file guards: on macOS the Objective-C runtime aborts a
# forked child that opens a ragg or quartz PNG device, so every method exporting
# graphics died silently under `artma.general.parallel = TRUE`. The worker was
# killed rather than throwing, so it surfaced as a failure with an empty message.

test_that("save_plot writes a valid PNG from inside a forked worker", {
  box::use(
    artma / modules / method_execution[execute_method_layer],
    artma / visualization / export[save_plot],
    artma / visualization / fork_safety[fork_safe_png_available]
  )

  skip_if(!can_fork(), "forking is unavailable")
  skip_if(!fork_safe_png_available(), "no fork-safe graphics device on this platform")
  local_ragg_in_forks()

  export_dir <- withr::local_tempdir()
  plot <- ggplot2::ggplot(data.frame(x = 1:10, y = 1:10), ggplot2::aes(x, y)) +
    ggplot2::geom_point()

  outcomes <- execute_method_layer(
    c("first", "second"),
    run_one = function(name) {
      save_plot(plot, file.path(export_dir, paste0(name, ".png")))
      name
    },
    workers = 2L
  )

  for (outcome in outcomes) {
    expect_null(outcome$error)
  }
  expect_equal(vapply(outcomes, function(o) o$value, character(1)), c("first", "second"))

  for (name in c("first", "second")) {
    path <- file.path(export_dir, paste0(name, ".png"))
    expect_true(file.exists(path))
    # A device that opened with the wrong units writes a near-empty file, so
    # assert on the raster dimensions rather than mere existence.
    expect_equal(png_dim(path), c(800L, 1100L))
  }
})

test_that("open_png_device writes a valid PNG from inside a forked worker", {
  box::use(
    artma / modules / method_execution[execute_method_layer],
    artma / visualization / export[open_png_device],
    artma / visualization / fork_safety[fork_safe_png_available]
  )

  skip_if(!can_fork(), "forking is unavailable")
  skip_if(!fork_safe_png_available(), "no fork-safe graphics device on this platform")
  local_ragg_in_forks()

  export_dir <- withr::local_tempdir()

  outcomes <- execute_method_layer(
    c("first", "second"),
    run_one = function(name) {
      open_png_device(file.path(export_dir, paste0(name, ".png")), width = 800, height = 600)
      on.exit(grDevices::dev.off(), add = TRUE)
      graphics::plot(1:10)
      name
    },
    workers = 2L
  )

  for (outcome in outcomes) {
    expect_null(outcome$error)
  }

  for (name in c("first", "second")) {
    path <- file.path(export_dir, paste0(name, ".png"))
    expect_true(file.exists(path))
    expect_equal(png_dim(path), c(800L, 600L))
  }
})

test_that("the forked-worker flag is confined to the child process", {
  box::use(
    artma / modules / method_execution[execute_method_layer],
    artma / visualization / fork_safety[in_forked_worker]
  )

  skip_if(!can_fork(), "forking is unavailable")

  outcomes <- execute_method_layer(
    c("a", "b"),
    run_one = function(name) in_forked_worker(),
    workers = 2L
  )

  expect_true(all(vapply(outcomes, function(o) isTRUE(o$value), logical(1))))
  expect_false(in_forked_worker())
})

test_that("sequential runs keep the default device", {
  box::use(
    artma / modules / method_execution[execute_method_layer],
    artma / visualization / fork_safety[use_fork_safe_png_device]
  )

  outcomes <- execute_method_layer(
    "a",
    run_one = function(name) use_fork_safe_png_device(),
    workers = 1L
  )

  expect_false(isTRUE(outcomes[[1L]]$value))
})

test_that("fork_safe_png_device sizes the raster in inches", {
  box::use(artma / visualization / fork_safety[fork_safe_png_available, fork_safe_png_device])

  skip_if(!fork_safe_png_available(), "cairo is unavailable")

  path <- withr::local_tempfile(fileext = ".png")

  # `ggsave()` resolves the size to inches before handing it to the device.
  fork_safe_png_device(path, width = 4, height = 3, res = 100)
  graphics::plot(1:10)
  grDevices::dev.off()

  expect_equal(png_dim(path), c(400L, 300L))
})

test_that("base_png_device sizes the raster in inches", {
  box::use(artma / visualization / export[base_png_device])

  path <- withr::local_tempfile(fileext = ".png")

  base_png_device(path, width = 4, height = 3, res = 100)
  graphics::plot(1:10)
  grDevices::dev.off()

  expect_equal(png_dim(path), c(400L, 300L))
})

test_that("fork_safe_png_available probes the device rather than the build flag", {
  box::use(artma / visualization / fork_safety[fork_safe_png_available, probe_cairo_png])

  # `capabilities("cairo")` reports how R was built; some headless macOS
  # installations report TRUE while the device writes nothing, which is why the
  # answer comes from an actual write.
  expect_equal(fork_safe_png_available(refresh = TRUE), probe_cairo_png())
  expect_true(is.logical(probe_cairo_png()))
  expect_equal(length(probe_cairo_png()), 1L)
})

test_that("a platform without a working cairo device never forks its graphics", {
  box::use(
    artma / visualization / fork_safety[
      fork_safe_png_available, graphics_fork_is_hostile, graphics_survive_fork,
      use_fork_safe_png_device
    ]
  )

  # Without a working cairo device there is nothing safe to swap in, so a
  # hostile platform must report that graphics cannot survive a fork. That is
  # what pushes `resolve_worker_count()` back to sequential execution.
  if (graphics_fork_is_hostile() && !fork_safe_png_available()) {
    expect_false(graphics_survive_fork())
    expect_false(use_fork_safe_png_device())
  } else {
    expect_true(graphics_survive_fork())
  }
})

test_that("resolve_worker_count stays sequential when a fork cannot draw", {
  box::use(artma / modules / method_execution[resolve_worker_count])

  withr::local_options(list(artma.visualization.export_graphics = TRUE))

  expect_equal(
    resolve_worker_count(
      4L,
      is_interactive = FALSE, os_type = "unix", n_cores = 8L,
      max_workers = Inf, graphics_fork_safe = FALSE, blas_fork_safe = TRUE
    ),
    1L
  )
  expect_equal(
    resolve_worker_count(
      4L,
      is_interactive = FALSE, os_type = "unix", n_cores = 8L,
      max_workers = Inf, graphics_fork_safe = TRUE, blas_fork_safe = TRUE
    ),
    4L
  )
})

test_that("with_single_threaded_blas evaluates and returns expr's value", {
  box::use(artma / visualization / fork_safety[with_single_threaded_blas])

  expect_equal(with_single_threaded_blas(1 + 1), 2)
  expect_error(with_single_threaded_blas(stop("boom")), "boom")
})

test_that("with_single_threaded_blas pins BLAS/OpenMP to one thread and restores them", {
  box::use(artma / visualization / fork_safety[with_single_threaded_blas])

  skip_if_not_installed("RhpcBLASctl")
  # RhpcBLASctl reports NA for every OpenMP query when R itself was not built
  # with OpenMP support (common on macOS toolchains); there is nothing to pin
  # or restore in that case.
  skip_if(is.na(RhpcBLASctl::omp_get_max_threads()), "R was not built with OpenMP support")

  # Start from a known, non-default OpenMP thread count so restoration can be
  # told apart from the pinned-down value used during `expr`.
  RhpcBLASctl::omp_set_num_threads(2L)
  withr::defer(RhpcBLASctl::omp_set_num_threads(RhpcBLASctl::omp_get_num_procs()))

  during <- with_single_threaded_blas(RhpcBLASctl::omp_get_max_threads())

  expect_equal(during, 1L)
  expect_equal(RhpcBLASctl::omp_get_max_threads(), 2L)
})

test_that("resolve_worker_count ignores fork-unsafe graphics when not exporting", {
  box::use(artma / modules / method_execution[resolve_worker_count])

  withr::local_options(list(artma.visualization.export_graphics = FALSE))

  expect_equal(
    resolve_worker_count(
      4L,
      is_interactive = FALSE, os_type = "unix", n_cores = 8L,
      max_workers = Inf, graphics_fork_safe = FALSE, blas_fork_safe = TRUE
    ),
    4L
  )
})

test_that("preview_plot prints in the parent but not inside a forked worker", {
  box::use(
    artma / visualization / export[preview_plot],
    artma / visualization / fork_safety[with_forked_worker_flag]
  )

  # `preview_plot()` calls `print()` from inside a box module, whose scope
  # chain bypasses the global environment, so the probe method must go through
  # the S3 registration table to be dispatched. The registration is process
  # local and the class is fake, so no cleanup is needed.
  calls <- new.env(parent = emptyenv())
  calls$n <- 0L
  registerS3method(
    "print", "artma_preview_probe",
    function(x, ...) {
      calls$n <- calls$n + 1L
      invisible(x)
    },
    envir = globalenv()
  )

  probe <- structure(list(), class = "artma_preview_probe")

  # `file_preview = FALSE` pins the print path: on a macOS terminal the file
  # preview would otherwise take over and skip the device entirely.
  with_forked_worker_flag(preview_plot(probe, file_preview = FALSE))
  expect_equal(calls$n, 0L)

  preview_plot(probe, file_preview = FALSE)
  expect_equal(calls$n, 1L)

  expect_null(preview_plot(NULL, file_preview = FALSE))
  expect_equal(calls$n, 1L)
})

test_that("a forked worker previewing a plot survives", {
  box::use(
    artma / modules / method_execution[execute_method_layer],
    artma / visualization / export[preview_plot]
  )

  skip_if(!can_fork(), "forking is unavailable")

  # The regression: methods previewed plots at verbosity >= 3 with a bare
  # `print()`, which opens the default interactive device. On macOS that is
  # quartz, and the Objective-C runtime kills a forked child that touches it,
  # so the whole method died before its exports ran.
  plot <- ggplot2::ggplot(data.frame(x = 1:10, y = 1:10), ggplot2::aes(x, y)) +
    ggplot2::geom_point()

  outcomes <- execute_method_layer(
    c("first", "second"),
    run_one = function(name) {
      preview_plot(plot)
      name
    },
    workers = 2L
  )

  for (outcome in outcomes) {
    expect_null(outcome$error)
  }
  expect_equal(vapply(outcomes, function(o) o$value, character(1)), c("first", "second"))
})

test_that("blas_threading_fork_hostile flags an OpenMP-linked BLAS", {
  box::use(artma / visualization / fork_safety[blas_threading_fork_hostile])

  linked_to_gomp <- function(path) {
    c("/fake/libopenblas.so:", "\tlibgomp.so.1 => /usr/lib/libgomp.so.1")
  }
  linked_to_pthread_only <- function(path) {
    c("/fake/libopenblas.so:", "\tlibpthread.so.0 => /usr/lib/libpthread.so.0")
  }

  expect_true(blas_threading_fork_hostile(
    blas = "/fake/libopenblas.so", lapack = "",
    list_linked = linked_to_gomp, omp_threads_env = ""
  ))
  expect_false(blas_threading_fork_hostile(
    blas = "/fake/libopenblas.so", lapack = "",
    list_linked = linked_to_pthread_only, omp_threads_env = ""
  ))
})

test_that("blas_threading_fork_hostile flags Accelerate and honours OMP_NUM_THREADS=1", {
  box::use(artma / visualization / fork_safety[blas_threading_fork_hostile])

  never_called <- function(path) stop("linkage must not be inspected")

  # Accelerate/vecLib dispatches through GCD; the path alone settles it.
  expect_true(blas_threading_fork_hostile(
    blas = "/System/Library/Frameworks/Accelerate.framework/Versions/A/libBLAS.dylib",
    lapack = "", list_linked = never_called, omp_threads_env = ""
  ))

  # A runtime capped to one thread from process start never spawns the pool.
  expect_false(blas_threading_fork_hostile(
    blas = "/fake/libopenblas.so", lapack = "",
    list_linked = never_called, omp_threads_env = "1"
  ))
})

test_that("blas_threading_fork_hostile treats the bundled reference BLAS as safe", {
  box::use(artma / visualization / fork_safety[blas_threading_fork_hostile])

  expect_false(blas_threading_fork_hostile(
    blas = "", lapack = "",
    list_linked = function(path) stop("linkage must not be inspected"),
    omp_threads_env = ""
  ))
})

test_that("blas_survives_fork caches a logical probe result", {
  box::use(artma / visualization / fork_safety[blas_survives_fork])

  first <- blas_survives_fork(refresh = TRUE)
  expect_true(is.logical(first) && length(first) == 1L)
  expect_equal(blas_survives_fork(), first)
})