diff --git a/NAMESPACE b/NAMESPACE index 4b8664fb..c9446797 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -19,6 +19,8 @@ export(dust_likelihood_rng_state) export(dust_likelihood_run) export(dust_likelihood_set_rng_state) export(dust_ode_control) +export(dust_openmp_support) +export(dust_openmp_threads) export(dust_package) export(dust_system_compare_data) export(dust_system_create) diff --git a/R/cpp11.R b/R/cpp11.R index e21ac619..3f2ed00d 100644 --- a/R/cpp11.R +++ b/R/cpp11.R @@ -156,6 +156,10 @@ dust2_filter_malaria_set_rng_state <- function(ptr, r_rng_state) { .Call(`_dust2_dust2_filter_malaria_set_rng_state`, ptr, r_rng_state) } +cpp_openmp_info <- function() { + .Call(`_dust2_cpp_openmp_info`) +} + dust2_system_sir_alloc <- function(r_pars, r_time, r_time_control, r_n_particles, r_n_groups, r_seed, r_deterministic, r_n_threads) { .Call(`_dust2_dust2_system_sir_alloc`, r_pars, r_time, r_time_control, r_n_particles, r_n_groups, r_seed, r_deterministic, r_n_threads) } diff --git a/R/openmp.R b/R/openmp.R index b2df5699..a8bafef8 100644 --- a/R/openmp.R +++ b/R/openmp.R @@ -1,3 +1,174 @@ +##' Return information about OpenMP support for this machine. +##' +##' @title Information about OpenMP support +##' +##' @param check_compile Logical, indicating if we should check if we +##' can compile an OpenMP program - this is slow the first time. +##' +##' @seealso [dust_openmp_threads()] for setting a polite number of +##' threads. +##' +##' @return A list with information about the OpenMP support on your +##' machine. +##' +##' * The first few elements come from the OpenMP library directly: +##' `num_proc`, `max_threads`, `thread_limit`; these correspond to a +##' call to the function `omp_get_()` in C and +##' `openmp_version` which is the value of the `_OPENMP` macro. +##' * A logical `has_openmp` which is `TRUE` if it looks like runtime +##' OpenMP support is available +##' * The next elements tell you about different sources that might +##' control the number of threads allowed to run: `mc.cores` (from +##' the R option with the same name), `OMP_THREAD_LIMIT`, +##' `OMP_NUM_THREADS`, `MC_CORES` (from environment variables), +##' `limit_r` (limit computed against R-related control variables), +##' `limit_openmp` (limit computed against OpenMP-related variables) +##' and `limit` the smaller of `limit_r` and `limit_openmp` +##' * Finally, if you specified `check_compile = TRUE`, the logical +##' `has_openmp_compiler` will indicate if it looks like we can +##' compile with OpenMP. +##' +##' @export +##' @examples +##' dust_openmp_support() +dust_openmp_support <- function(check_compile = FALSE) { + info <- openmp_info() + if (check_compile) { + info$has_openmp_compiler <- has_openmp_compiler() + } + info +} + + +##' Politely select a number of threads to use. See Details for the +##' algorithm used. +##' +##' There are two limits and we will take the smaller of the two. +##' +##' The first limit comes from piggy-backing off of R's normal +##' parallel configuration; we will use the `MC_CORES` environment +##' variable and `mc.cores` option as a guide to how many cores you +##' are happy to use. We take `mc.cores` first, then `MC_CORES`, which +##' is the same behaviour as `parallel::mclapply` and friends. +##' +##' The second limit comes from OpenMP. If you do not have OpenMP +##' support, then we use one thread (higher numbers have no effect at +##' all in this case). If you do have OpenMP support, we take the +##' smallest of the number of "processors" (reported by +##' `omp_get_num_procs()`) the "max threads" (reported by +##' `omp_get_max_threads()` and "thread_limit" (reported by +##' `omp_get_thread_limit()`. +##' +##' See [dust_openmp_support()] for the values of all the values that +##' go into this calculation. +##' +##' @title Select number of threads +##' +##' @param n Either `NULL` (select automatically) or an integer as +##' your proposed number of threads. +##' +##' @param action An action to perform if `n` exceeds the maximum +##' number of threads you can use. Options are "error" (the default, +##' throw an error) or "fix" (print a message and reduce `n` down to +##' the limit). +##' +##' @return An integer, indicating the number of threads that you can use +##' @export +##' @examples +##' # Default number of threads; tries to pick something friendly, +##' # erring on the conservative side. +##' dust_openmp_threads(NULL) +##' +##' # Try to pick something silly and it will be reduced for you +##' dust_openmp_threads(1000, action = "fix") +dust_openmp_threads <- function(n = NULL, action = "error") { + info <- openmp_info() + if (is.null(n)) { + n <- info$limit + } else { + n <- openmp_check_limit(n, info$limit, action) + } + n +} + + +has_openmp_compiler <- function() { + if (is.null(cache$has_openmp_compiler)) { + cache$has_openmp_compiler <- has_openmp_compiler_test() + } + cache$has_openmp_compiler +} + + +## This test uses the 'parallel' example, which as its update() method +## returns the thread number by running omp_get_thread_num() +has_openmp_compiler_test <- function() { + workdir <- tempfile("dust_") + dir_create(workdir) + dir_create(file.path(workdir, "src")) + data <- list(package = "dustopenmp", + linking_to = "cpp11, dust2, monty", + compiler_options = "", + system_requirements = "R (>= 4.0.0)") + writeLines(substitute_dust_template(data, "DESCRIPTION"), + file.path(workdir, "DESCRIPTION")) + writeLines(substitute_dust_template(data, "NAMESPACE"), + file.path(workdir, "NAMESPACE")) + writeLines(substitute_dust_template(data, "Makevars"), + file.path(workdir, "src", "Makevars")) + stopifnot(file.copy(dust2_file("openmp.cpp"), + file.path(workdir, "src"), + overwrite = TRUE)) + tryCatch({ + pkgbuild::compile_dll(workdir, compile_attributes = TRUE, + quiet = TRUE, debug = FALSE) + env <- load_temporary_package(workdir, data$package, TRUE) + env$openmp_get_thread_id() >= 0 + }, error = function(e) FALSE) +} + + +## NOTE: This does not return if the *compiler* supports OpenMP, just +## the runtime. While we are testing that will be the same thing, but +## after installation from binary this requires really a compile time +## test of a simple OpenMP program. +openmp_info <- function() { + env <- Sys.getenv(c("OMP_THREAD_LIMIT", "OMP_NUM_THREADS", "MC_CORES")) + env <- set_names(as.list(as.integer(env)), names(env)) + info <- cpp_openmp_info() + info[["mc.cores"]] <- getOption("mc.cores", NA_integer_) + + limit <- list() + limit$limit_r <- getOption("mc.cores", as.integer(Sys.getenv("MC_CORES", 1))) + limit$limit_openmp <- min(info$num_procs, + info$num_threads, + info$thread_limit) + if (!info$has_openmp) { + limit$limit_openmp <- 1L + } + limit$limit <- min(limit$limit_r, limit$limit_openmp) + + c(info, env, limit) +} + + +openmp_check_limit <- function(n, limit, action, call = parent.frame()) { + match_value(action, c("error", "fix")) + if (n > limit) { + msg <- "Requested number of threads '{n}' exceeds a limit of '{limit}'" + hint <- "See {.help dust_openmp_threads()} for details" + if (action == "error") { + cli::cli_abort(c(msg, i = hint), call = call) + } else { + cli::cli_alert_warning(msg) + cli::cli_alert_info(hint) + n <- limit + } + } + n +} + + ## We should have the system report back if it supports openmp at all, ## and pass that in here too, because that deserves a warning. ## diff --git a/_pkgdown.yml b/_pkgdown.yml index 0d60dee9..f559dd09 100644 --- a/_pkgdown.yml +++ b/_pkgdown.yml @@ -51,6 +51,8 @@ reference: contents: - dust_unpack_state - dust_unpack_index + - dust_openmp_support + - dust_openmp_threads - title: Browser-based debugging contents: - dust_browser_enabled diff --git a/inst/openmp.cpp b/inst/openmp.cpp new file mode 100644 index 00000000..03375fce --- /dev/null +++ b/inst/openmp.cpp @@ -0,0 +1,12 @@ +#ifdef _OPENMP +#include +#endif + +[[cpp11::register]] +int openmp_get_thread_id() { +#ifdef _OPENMP + return omp_get_thread_num(); +#else + return -1; +#endif +} diff --git a/man/dust_openmp_support.Rd b/man/dust_openmp_support.Rd new file mode 100644 index 00000000..40af4701 --- /dev/null +++ b/man/dust_openmp_support.Rd @@ -0,0 +1,44 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/openmp.R +\name{dust_openmp_support} +\alias{dust_openmp_support} +\title{Information about OpenMP support} +\usage{ +dust_openmp_support(check_compile = FALSE) +} +\arguments{ +\item{check_compile}{Logical, indicating if we should check if we +can compile an OpenMP program - this is slow the first time.} +} +\value{ +A list with information about the OpenMP support on your +machine. +\itemize{ +\item The first few elements come from the OpenMP library directly: +\code{num_proc}, \code{max_threads}, \code{thread_limit}; these correspond to a +call to the function \verb{omp_get_()} in C and +\code{openmp_version} which is the value of the \verb{_OPENMP} macro. +\item A logical \code{has_openmp} which is \code{TRUE} if it looks like runtime +OpenMP support is available +\item The next elements tell you about different sources that might +control the number of threads allowed to run: \code{mc.cores} (from +the R option with the same name), \code{OMP_THREAD_LIMIT}, +\code{OMP_NUM_THREADS}, \code{MC_CORES} (from environment variables), +\code{limit_r} (limit computed against R-related control variables), +\code{limit_openmp} (limit computed against OpenMP-related variables) +and \code{limit} the smaller of \code{limit_r} and \code{limit_openmp} +\item Finally, if you specified \code{check_compile = TRUE}, the logical +\code{has_openmp_compiler} will indicate if it looks like we can +compile with OpenMP. +} +} +\description{ +Return information about OpenMP support for this machine. +} +\examples{ +dust_openmp_support() +} +\seealso{ +\code{\link[=dust_openmp_threads]{dust_openmp_threads()}} for setting a polite number of +threads. +} diff --git a/man/dust_openmp_threads.Rd b/man/dust_openmp_threads.Rd new file mode 100644 index 00000000..cd7b4bda --- /dev/null +++ b/man/dust_openmp_threads.Rd @@ -0,0 +1,52 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/openmp.R +\name{dust_openmp_threads} +\alias{dust_openmp_threads} +\title{Select number of threads} +\usage{ +dust_openmp_threads(n = NULL, action = "error") +} +\arguments{ +\item{n}{Either \code{NULL} (select automatically) or an integer as +your proposed number of threads.} + +\item{action}{An action to perform if \code{n} exceeds the maximum +number of threads you can use. Options are "error" (the default, +throw an error) or "fix" (print a message and reduce \code{n} down to +the limit).} +} +\value{ +An integer, indicating the number of threads that you can use +} +\description{ +Politely select a number of threads to use. See Details for the +algorithm used. +} +\details{ +There are two limits and we will take the smaller of the two. + +The first limit comes from piggy-backing off of R's normal +parallel configuration; we will use the \code{MC_CORES} environment +variable and \code{mc.cores} option as a guide to how many cores you +are happy to use. We take \code{mc.cores} first, then \code{MC_CORES}, which +is the same behaviour as \code{parallel::mclapply} and friends. + +The second limit comes from OpenMP. If you do not have OpenMP +support, then we use one thread (higher numbers have no effect at +all in this case). If you do have OpenMP support, we take the +smallest of the number of "processors" (reported by +\code{omp_get_num_procs()}) the "max threads" (reported by +\code{omp_get_max_threads()} and "thread_limit" (reported by +\code{omp_get_thread_limit()}. + +See \code{\link[=dust_openmp_support]{dust_openmp_support()}} for the values of all the values that +go into this calculation. +} +\examples{ +# Default number of threads; tries to pick something friendly, +# erring on the conservative side. +dust_openmp_threads(NULL) + +# Try to pick something silly and it will be reduced for you +dust_openmp_threads(1000, action = "fix") +} diff --git a/src/cpp11.cpp b/src/cpp11.cpp index 7c3bf68f..afe86d5c 100644 --- a/src/cpp11.cpp +++ b/src/cpp11.cpp @@ -278,6 +278,13 @@ extern "C" SEXP _dust2_dust2_filter_malaria_set_rng_state(SEXP ptr, SEXP r_rng_s return cpp11::as_sexp(dust2_filter_malaria_set_rng_state(cpp11::as_cpp>(ptr), cpp11::as_cpp>(r_rng_state))); END_CPP11 } +// openmp.cpp +cpp11::writable::list cpp_openmp_info(); +extern "C" SEXP _dust2_cpp_openmp_info() { + BEGIN_CPP11 + return cpp11::as_sexp(cpp_openmp_info()); + END_CPP11 +} // sir.cpp SEXP dust2_system_sir_alloc(cpp11::list r_pars, cpp11::sexp r_time, cpp11::list r_time_control, cpp11::sexp r_n_particles, cpp11::sexp r_n_groups, cpp11::sexp r_seed, cpp11::sexp r_deterministic, cpp11::sexp r_n_threads); extern "C" SEXP _dust2_dust2_system_sir_alloc(SEXP r_pars, SEXP r_time, SEXP r_time_control, SEXP r_n_particles, SEXP r_n_groups, SEXP r_seed, SEXP r_deterministic, SEXP r_n_threads) { @@ -827,6 +834,7 @@ extern "C" SEXP _dust2_dust2_system_walk_simulate(SEXP ptr, SEXP r_times, SEXP r extern "C" { static const R_CallMethodDef CallEntries[] = { + {"_dust2_cpp_openmp_info", (DL_FUNC) &_dust2_cpp_openmp_info, 0}, {"_dust2_dust2_filter_malaria_alloc", (DL_FUNC) &_dust2_dust2_filter_malaria_alloc, 10}, {"_dust2_dust2_filter_malaria_last_history", (DL_FUNC) &_dust2_dust2_filter_malaria_last_history, 5}, {"_dust2_dust2_filter_malaria_last_state", (DL_FUNC) &_dust2_dust2_filter_malaria_last_state, 5}, diff --git a/src/openmp.cpp b/src/openmp.cpp new file mode 100644 index 00000000..9518005f --- /dev/null +++ b/src/openmp.cpp @@ -0,0 +1,29 @@ +#ifdef _OPENMP +#include +#endif + +#include +#include + +[[cpp11::register]] +cpp11::writable::list cpp_openmp_info() { +#ifdef _OPENMP + const int num_procs = omp_get_num_procs(); + const int max_threads = omp_get_max_threads(); + const int thread_limit = omp_get_thread_limit(); + static int openmp_version = _OPENMP; + static bool has_openmp = true; +#else + static int num_procs = NA_INTEGER; + static int max_threads = NA_INTEGER; + static int thread_limit = NA_INTEGER; + static int openmp_version = NA_INTEGER; + static bool has_openmp = false; +#endif + using namespace cpp11::literals; + return cpp11::writable::list({"num_procs"_nm = num_procs, + "max_threads"_nm = max_threads, + "thread_limit"_nm = thread_limit, + "openmp_version"_nm = openmp_version, + "has_openmp"_nm = has_openmp}); +} diff --git a/tests/testthat/test-openmp.R b/tests/testthat/test-openmp.R index f717ad07..74869e7b 100644 --- a/tests/testthat/test-openmp.R +++ b/tests/testthat/test-openmp.R @@ -7,3 +7,142 @@ test_that("Can validate thread count", { "Reducing 'n_threads' from requested 10 to 6") expect_equal(n, 6) }) + + +test_that("dust_openmp_info contains expected fields", { + info <- dust_openmp_support() + expect_type(info, "list") + nms <- c("num_procs", "max_threads", "thread_limit", "openmp_version", + "has_openmp", "mc.cores", "OMP_THREAD_LIMIT", "OMP_NUM_THREADS", + "MC_CORES", "limit_r", "limit_openmp", "limit") + expect_equal(names(info), nms) +}) + + +test_that("dust_openmp_info contains expected fields", { + skip_on_cran() + info1 <- dust_openmp_support() + info2 <- dust_openmp_support(TRUE) + expect_equal( + setdiff(names(info2), names(info1)), + "has_openmp_compiler") + expect_equal( + setdiff(names(info1), names(info2)), + character()) + expect_equal(info2$has_openmp_compiler, cache$has_openmp_compiler) +}) + + +test_that("check limit", { + expect_error( + openmp_check_limit(10, 2, "error"), + "Requested number of threads '10' exceeds a limit of '2'") + + res <- evaluate_promise( + openmp_check_limit(10, 2, "fix")) + expect_match(res$messages[[1]], + "Requested number of threads '10' exceeds a limit of '2'") + expect_equal(res$result, 2) +}) + + +test_that("limit is 1 if openmp not supported", { + skip_if_not_installed("mockery") + mock_info <- mockery::mock( + list(num_procs = NA_integer_, max_threads = NA_integer_, + thread_limit = NA_integer_, openmp_version = NA_integer_, + has_openmp = FALSE)) + mockery::stub(openmp_info, "cpp_openmp_info", mock_info) + res <- openmp_info() + + mockery::expect_called(mock_info, 1L) + expect_equal(res$limit, 1) + expect_identical(res$limit_openmp, 1L) +}) + + +test_that("limit is more than 1 if openmp supported", { + skip_if_not_installed("mockery") + mock_info <- mockery::mock( + list(num_procs = 8L, max_threads = 8L, + thread_limit = 1024L, openmp_version = 201511L, + has_openmp = TRUE)) + mockery::stub(openmp_info, "cpp_openmp_info", mock_info) + res <- withr::with_options( + list(mc.cores = 4), + openmp_info()) + mockery::expect_called(mock_info, 1L) + expect_equal(res$limit, 4) + expect_equal(res$limit_openmp, 8L) + expect_equal(res$limit_r, 4) +}) + + +test_that("order of preference for R's limits", { + expect_equal( + withr::with_options( + list(mc.cores = 4), + withr::with_envvar( + c("MC_CORES" = 8), + unname(openmp_info()[c("mc.cores", "MC_CORES", "limit_r")]))), + list(4, 8, 4)) + + expect_equal( + withr::with_options( + list(mc.cores = 8), + withr::with_envvar( + c("MC_CORES" = 4), + unname(openmp_info()[c("mc.cores", "MC_CORES", "limit_r")]))), + list(8, 4, 8)) +}) + + +test_that("detect compilation failure", { + skip_if_not_installed("mockery") + mock_compile <- mockery::mock( + stop("compilation failed!")) + mockery::stub(has_openmp_compiler_test, "pkgbuild::compile_dll", + mock_compile) + expect_false(has_openmp_compiler_test()) +}) + + +test_that("detect compilation success, but no support", { + skip_if_not_installed("mockery") + mock_thread_id <- mockery::mock(-1, 0) + mock_compile <- mockery::mock() + mock_load <- mockery::mock(list(openmp_get_thread_id = mock_thread_id)) + mockery::stub(has_openmp_compiler_test, "pkgbuild::compile_dll", + mock_compile) + mockery::stub(has_openmp_compiler_test, "load_temporary_package", + mock_load) + expect_false(has_openmp_compiler_test()) + mockery::expect_called(mock_thread_id, 1L) +}) + + +test_that("detect compilation success, with support", { + skip_if_not_installed("mockery") + mock_thread_id <- mockery::mock(0) + mock_compile <- mockery::mock() + mock_load <- mockery::mock(list(openmp_get_thread_id = mock_thread_id)) + mockery::stub(has_openmp_compiler_test, "pkgbuild::compile_dll", + mock_compile) + mockery::stub(has_openmp_compiler_test, "load_temporary_package", + mock_load) + expect_true(has_openmp_compiler_test()) + mockery::expect_called(mock_thread_id, 1L) +}) + + +test_that("dust_openmp_threads interface works", { + expect_equal( + dust_openmp_threads(NULL), + dust_openmp_support()$limit) + expect_equal( + suppressMessages(dust_openmp_threads(1000, action = "fix")), + dust_openmp_support()$limit) + expect_equal( + dust_openmp_threads(1, action = "error"), + 1) +}) diff --git a/tests/testthat/test-zzz-compile.R b/tests/testthat/test-zzz-compile.R index 134a42b7..334d43f4 100644 --- a/tests/testthat/test-zzz-compile.R +++ b/tests/testthat/test-zzz-compile.R @@ -73,7 +73,7 @@ test_that("generators can be serialised and used from other processes", { dust2::dust_system_state(dust2::dust_system_create(sys(), list(), 1)) }, list(tmp), stdout = log, stderr = "2>&1"), numeric(5)) - expect_match(cli::ansi_string(readLines(log)), "Loading mysir", all = FALSE) + expect_match(cli::ansi_strip(readLines(log)), "Loading mysir", all = FALSE) })