# npRmpi attach-mode startup profile template
#
# Usage (batch/cluster):
#   1) copy this file to your working directory as .Rprofile, or set
#      R_PROFILE_USER to this file path.
#   2) launch with mpiexec/mpirun, e.g.
#      mpiexec -n 6 R CMD BATCH --no-save script.R
#
# Non-master ranks enter a receive/eval loop and execute commands sent by
# mpi.bcast.cmd(...). Rank 0 continues script execution.

.nonblock <- TRUE
.sleep <- 0.1
quiet <- FALSE
.recv.timeout <- suppressWarnings(as.numeric(Sys.getenv(
  "NP_RMPI_PROFILE_RECV_TIMEOUT_SEC", "0"
)))
if (!is.finite(.recv.timeout) || .recv.timeout <= 0)
  .recv.timeout <- 0

.profile_canon <- function(path) {
  if (!nzchar(path))
    return("")
  tryCatch(
    normalizePath(path.expand(path), winslash = "/", mustWork = FALSE),
    error = function(e) path.expand(path)
  )
}

.profile_user <- .profile_canon(Sys.getenv("R_PROFILE_USER", unset = ""))
.profile_site <- .profile_canon(Sys.getenv("R_PROFILE", unset = ""))

if (nzchar(.profile_user) && nzchar(.profile_site) &&
    identical(.profile_user, .profile_site)) {
  msg <- paste(
    "npRmpi profile startup misconfiguration:",
    "R_PROFILE_USER and R_PROFILE point to the same file.",
    "This can deadlock MPI profile/manual-broadcast startup.",
    "Remediation: keep only one profile source (prefer R_PROFILE_USER)",
    "and unset R_PROFILE for this launch."
  )
  base::cat(sprintf("\n[npRmpi profile guard] %s\n", msg), file = stderr())
  flush(stderr())
  stop(msg, call. = FALSE)
}

if (!invisible(library(npRmpi, logical.return = TRUE))) {
  warning("npRmpi cannot be loaded")
  q(save = "no")
}

# Profile/manual-broadcast launches should preserve the same direct-call
# behavior as session/attach master contexts.
options(npRmpi.autodispatch = TRUE)
options(npRmpi.profile.active = TRUE)

# Guard against explicit Rmpi attachment inside profile scripts. Under the
# embedded npRmpi backend, attaching Rmpi then calling mpi.comm.rank() in this
# mode can crash the process; fail fast with remediation instead.
.npRmpi_profile_rmpi_attach_guard <- function(...) {
  if (!isTRUE(getOption("npRmpi.profile.active", FALSE)))
    return(invisible(NULL))
  msg <- paste(
    "npRmpi profile mode does not support attaching package 'Rmpi' in script body.",
    "Use npRmpi profile/manual-broadcast helpers (mpi.bcast.*) without library(Rmpi),",
    "or switch to attach/session mode if direct Rmpi APIs are required."
  )
  .stub <- function(...) stop(msg, call. = FALSE)
  assign("mpi.comm.rank", .stub, envir = .GlobalEnv)
  assign("mpi.comm.size", .stub, envir = .GlobalEnv)
  base::cat(sprintf("\n[npRmpi profile guard] %s\n", msg), file = stderr())
  flush(stderr())
  if (interactive()) {
    stop(msg, call. = FALSE)
  } else {
    quit(save = "no", status = 1, runLast = FALSE)
  }
}
setHook(packageEvent("Rmpi", "attach"), .npRmpi_profile_rmpi_attach_guard, action = "append")
if ("package:Rmpi" %in% search())
  .npRmpi_profile_rmpi_attach_guard()

# Ensure core base/recommended packages are attached for worker-side eval
# when launched via Rscript + .Rprofile.
for (pkg in c("utils", "stats", "datasets", "grDevices", "graphics", "methods")) {
  if (!(paste0("package:", pkg) %in% search())) {
    suppressPackageStartupMessages(library(pkg, character.only = TRUE))
  }
}

options(error = quote(assign(".mpi.err", FALSE, envir = .GlobalEnv)))

if (mpi.comm.size(0) > 1)
  invisible(mpi.comm.dup(0, 1))

# Direct profile-mode autodispatch executes only on rank 0 script body, so
# slave ranks must have the embedded np MPI state primed before entering the
# worker loop. Canonical demos may still call np.mpi.initialize() explicitly;
# repeated initialization is tolerated by the embedded backend.
if (mpi.comm.size(0) > 1)
  np.mpi.initialize()

if (mpi.comm.rank(0) > 0) {
  options(echo = FALSE)
  .comm <- 1
  .npRmpi_ns <- asNamespace("npRmpi")
  .npRmpi_worker_loop <- get(".npRmpi_worker_loop", envir = .npRmpi_ns, inherits = FALSE)
  mpi.barrier(0)
  .npRmpi_worker_loop(
    comm = .comm,
    nonblock = .nonblock,
    sleep = .sleep,
    recv.timeout = .recv.timeout,
    loop.label = "profile slave",
    timeout.remediation = paste(
      "check profile env wiring (avoid dual R_PROFILE_USER/R_PROFILE),",
      "verify FI_* interface settings, and retry with a fresh MPI launch."
    )
  )
  mpi.comm.free(.comm)
  mpi.quit()
}

if (mpi.comm.rank(0) == 0) {
  mpi.barrier(0)
  if (mpi.comm.size(0) > 1 && !quiet)
    slave.hostinfo(1)
}

.Last <- function() {
  if (is.loaded("mpi_initialize")) {
    if (mpi.comm.size(1) > 1) {
      print("Please use mpi.close.Rslaves() to close slaves")
      mpi.close.Rslaves(comm = 1)
    }
  }
  if (is.loaded("mpi_initialize"))
    .Call("mpi_finalize", PACKAGE = "npRmpi")
}
