Prevent parallel functions from forking Ark (#1308)

Addresses posit-dev/positron#3817

This shims `mcfork()`, the forking primitive used by all entry points in
the parallel package. The shim fails with an informative R error.

In addition, `makeForkCluster()` is also shimmed because it swallows
`mcfork()` errors with an uninformative message.

If `mc.cores` is set to 1, `mcfork()` is not called as the {parallel}
function falls back to serial computation, which is the same behaviour
as on Windows where forking is not possible.

Author: lionel-

crates/ark/src/modules/positron/fork_guard.R

@@ -0,0 +1,83 @@
+#
+# fork_guard.R
+#
+# Copyright (C) 2026 Posit Software, PBC. All rights reserved.
+#
+#
+
+# ark's IOPub/ZMQ background threads don't survive `fork()`
+# (posit-dev/positron#3817). Every forking path in {parallel} funnels through
+# the internal `mcfork()`, the only R-level caller of the C fork primitive. So
+# shimming `mcfork()` with a stub that errors immediately blocks them all,
+# pointing the user at backends that launch fresh subprocesses instead.
+#
+# We also shim `makeForkCluster()` directly. It wraps `mcfork()` in a
+# `tryCatch()` and rethrows a generic "Cluster setup failed." on any error, so
+# our message would never reach the user otherwise. `makeCluster(type = "FORK")`
+# dispatches to `makeForkCluster()` through the namespace, so it is covered too.
+#
+# `mclapply()` and friends fall back to a serial `lapply()`/`mapply()` when
+# `mc.cores = 1` or the input has fewer than two elements. Those paths never
+# reach `mcfork()`, so they keep working and run serially, matching Windows
+# where {parallel} ships serial stubs (`R/windows/mcdummies.R`) and never forks.
+
+initialize_fork_guard <- function() {
+    # These functions only fork on Unix. On Windows {parallel} never forks, so
+    # there is nothing to guard.
+    if (is_windows()) {
+        return(invisible())
+    }
+
+    if (isNamespaceLoaded("parallel")) {
+        bind_fork_guard_ns()
+        if ("package:parallel" %in% search()) {
+            bind_fork_guard_pkg()
+        }
+    }
+
+    setHook(packageEvent("parallel", "onLoad"), function(...) {
+        bind_fork_guard_ns()
+    })
+    setHook(packageEvent("parallel", "attach"), function(...) {
+        bind_fork_guard_pkg()
+    })
+}
+
+# `mcfork()` is internal, so the namespace binding covers every caller. Only
+# `makeForkCluster()` is exported, so it also needs a package binding for
+# unqualified calls after `library(parallel)`.
+fork_guard_ns_names <- c("mcfork", "makeForkCluster")
+fork_guard_pkg_names <- "makeForkCluster"
+
+bind_fork_guard_ns <- function() {
+    for (name in fork_guard_ns_names) {
+        ns_bind("parallel", name, make_fork_guard_shim(name))
+    }
+}
+
+bind_fork_guard_pkg <- function() {
+    for (name in fork_guard_pkg_names) {
+        pkg_bind("parallel", name, make_fork_guard_shim(name))
+    }
+}
+
+make_fork_guard_shim <- function(name) {
+    original <- utils::getFromNamespace(name, "parallel")
+
+    # `ns_bind()`/`pkg_bind()` require the replacement to share the original's
+    # formals.
+    shim <- function() {}
+    formals(shim) <- formals(original)
+    body(shim) <- quote(stop_no_fork())
+
+    shim
+}
+
+stop_no_fork <- function() {
+    msg <- paste_line(c(
+        sprintf("Can't fork the R session in %s.", app_name()),
+        "Use a backend that starts fresh R processes instead: PSOCK clusters,",
+        "`future::multisession()`, mirai, or `purrr::in_parallel()`."
+    ))
+    stop(msg, call. = FALSE)
+}

crates/ark/src/modules/positron/init.R

@@ -158,4 +158,5 @@ initialize <- function() {
     initialize_debug()
     initialize_hooks()
     initialize_hooks_source()
+    initialize_fork_guard()
 }

crates/ark/src/modules/positron/system.R

@@ -18,6 +18,18 @@ is_windows <- function() {
     system_os() == "windows"
 }
 
+#' Name of the frontend Ark is running under.
+#'
+#' Positron sets the `POSITRON` env var when it launches Ark. Same signal
+#' `positron.R` uses to set `.Platform$GUI`.
+app_name <- function() {
+    if (Sys.getenv("POSITRON") == 1) {
+        "Positron"
+    } else {
+        "Ark"
+    }
+}
+
 has_aqua <- function() {
     capabilities("aqua")
 }

crates/ark/tests/integration/kernel_fork_guard.rs

@@ -0,0 +1,103 @@
+use ark_test::DummyArkFrontend;
+
+// `parallel` ships with base R, so no extra test dependency is needed.
+//
+// The fork guard only installs on Unix, because forking is the hazard and
+// Windows `parallel` never forks (it ships its own serial/`stop()` stubs in
+// `R/windows/mcdummies.R`). So the error tests below are `#[cfg(unix)]`: on
+// Windows these calls hit R's native behavior, which uses different messages
+// and even runs serially in some cases. The PSOCK tests stay cross-platform.
+
+#[cfg(unix)]
+#[test]
+fn test_fork_functions_error() {
+    let frontend = DummyArkFrontend::lock();
+
+    frontend.execute_request_error(
+        "parallel::mclapply(1:2, identity, mc.cores = 2)",
+        |error_msg| {
+            assert!(error_msg.contains("fork the R session"));
+        },
+    );
+
+    // `library(parallel)` attaches the package, exercising the `pkg_bind` /
+    // attach path. Unqualified `mclapply` should then hit the shim too.
+    frontend.execute_request_error("library(parallel); mclapply(1:2, identity)", |error_msg| {
+        assert!(error_msg.contains("fork the R session"));
+    });
+
+    frontend.execute_request_error("parallel::mcparallel(1)", |error_msg| {
+        assert!(error_msg.contains("fork the R session"));
+    });
+
+    frontend.execute_request_error("parallel::pvec(1:10, sqrt, mc.cores = 2)", |error_msg| {
+        assert!(error_msg.contains("fork the R session"));
+    });
+
+    frontend.execute_request_error(
+        "parallel::mcmapply(`+`, 1:2, 3:4, mc.cores = 2)",
+        |error_msg| {
+            assert!(error_msg.contains("fork the R session"));
+        },
+    );
+
+    frontend.execute_request_error("parallel::mcMap(`+`, 1:2, 3:4)", |error_msg| {
+        assert!(error_msg.contains("fork the R session"));
+    });
+
+    frontend.execute_request_error("parallel::makeForkCluster(2)", |error_msg| {
+        assert!(error_msg.contains("fork the R session"));
+    });
+
+    // `mcfork` is unexported, so triple-colon access exercises the
+    // namespace-only binding.
+    frontend.execute_request_error("parallel:::mcfork()", |error_msg| {
+        assert!(error_msg.contains("fork the R session"));
+    });
+
+    // The public `makeCluster(type = "FORK")` dispatches to `makeForkCluster`
+    // resolved through parallel's namespace, so it hits our shim too.
+    frontend.execute_request_error("parallel::makeCluster(2, type = \"FORK\")", |error_msg| {
+        assert!(error_msg.contains("fork the R session"));
+    });
+}
+
+// The multicore family runs serially, without forking, when `mc.cores = 1` or
+// the input has fewer than two elements. Those calls never reach `mcfork()`, so
+// the guard must leave them alone. This matches Windows, where {parallel} always
+// runs these serially.
+
+#[test]
+fn test_serial_execution_works() {
+    let frontend = DummyArkFrontend::lock();
+
+    frontend.execute_request(
+        "unlist(parallel::mclapply(1:4, function(x) x * 2L, mc.cores = 1))",
+        |result| assert_eq!(result, "[1] 2 4 6 8"),
+    );
+
+    frontend.execute_request(
+        "parallel::pvec(1:4, function(x) x * 2L, mc.cores = 1)",
+        |result| assert_eq!(result, "[1] 2 4 6 8"),
+    );
+}
+
+// PSOCK clusters start fresh R worker processes instead of forking the session,
+// so the guard must leave them untouched. These spawn real worker processes and
+// run a small parallel computation, asserting it returns the correct result.
+
+#[test]
+fn test_psock_cluster_works() {
+    let frontend = DummyArkFrontend::lock();
+
+    frontend.execute_request(
+        "local({ cl <- parallel::makePSOCKcluster(2); on.exit(parallel::stopCluster(cl)); sum(unlist(parallel::parLapply(cl, 1:4, function(x) x * 2L))) })",
+        |result| assert_eq!(result, "[1] 20"),
+    );
+
+    // `makeCluster()` defaults to a PSOCK cluster, which we don't guard.
+    frontend.execute_request(
+        "local({ cl <- parallel::makeCluster(2); on.exit(parallel::stopCluster(cl)); unlist(parallel::clusterApply(cl, 1:3, function(x) x + 1L)) })",
+        |result| assert_eq!(result, "[1] 2 3 4"),
+    );
+}

crates/ark/tests/integration/main.rs

@@ -26,6 +26,7 @@ mod kernel_captured_output;
 mod kernel_debugger;
 mod kernel_execute;
 mod kernel_execute_error;
+mod kernel_fork_guard;
 mod kernel_hooks_session;
 mod kernel_hooks_source;
 mod kernel_hooks_timestamp;