Updated compile function to handle C/C++ files in parallel

Author: simonbeyer1

NAMESPACE

@@ -186,9 +186,11 @@ export(getEquations)
 export(getFluxes)
 export(getLinVars)
 export(getLocalDLLs)
+export(getObjfiles)
 export(getObservables)
 export(getParameters)
 export(getReactions)
+export(getSourcefiles)
 export(getStepIndices)
 export(getSteps)
 export(ggopen)

R/tools.R

@@ -410,159 +410,233 @@ expand.grid.alt <- function(seq1, seq2) {
 }
 
 
-#' Compile one or more model-related functions
+#' Compile model-related C/C++ code
 #'
 #' @description
-#' Compiles one or more objects of class `parfn`, `obsfn`, or `prdfn` into
-#' shared libraries (`.so` or `.dll`).
+#' Compiles one or more model-related objects of class `parfn`, `obsfn`, or
+#' `prdfn` into dynamically loadable shared libraries (`.so` on Unix-alike
+#' systems, `.dll` on Windows).
 #'
-#' If `output` is `NULL`, each detected C/C++ source file is compiled and
-#' linked into its own shared object.
-#'
-#' If `output` is provided, all detected source files are compiled
-#' (optionally in parallel if multiple files are present and `cores > 1`)
-#' into object files (`.o`) and then linked together into a single shared
-#' library with the specified name.
-#'
-#' If no additional compiler flags are supplied via `args`, the compilation
-#' defaults to using `-O3` for optimization.
+#' The function automatically detects C and C++ source files associated
+#' with each object based on its `modelname`, compiles them, and links them
+#' into shared libraries which are loaded into the current R session.
 #'
 #' @param ... One or more objects of class `parfn`, `obsfn`, or `prdfn`.
-#'   The corresponding C/C++ source files (e.g., `model.c`, `model.cpp`,
-#'   `model_deriv.c`) are automatically detected based on the model name.
-#'
-#' @param output Optional character string. If supplied, all compiled object
-#'   files are linked into a single shared library named
-#'   `paste0(output, .Platform$dynlib.ext)`. If omitted, each source file is
-#'   built into a separate shared library.
-#'
-#' @param args Optional character string containing additional flags passed
-#'   to `R CMD SHLIB` during compilation and linking (e.g., `"-leinspline"`).
-#'   If `NULL` or empty, the compiler is invoked with `-O3`.
-#'
+#'   Corresponding source files (e.g. `model.c`) are detected
+#'   automatically based on the current `modelname`.
+#' @param output Optional character string. If provided, all detected source
+#'   files are compiled and linked into a single shared library named
+#'   `paste0(output, .Platform$dynlib.ext)`. If `NULL`, each source file is
+#'   compiled and linked into its own shared library.
+#' @param args Optional character string of additional compiler or linker
+#'   flags passed to `R CMD SHLIB`. If `NULL` or empty, compilation defaults
+#'   to `-O3 -DNDEBUG`.
+#' @param cores Integer specifying the number of CPU cores used for parallel
+#'   compilation of individual source files. Parallel compilation is enabled
+#'   when `cores > 1`.
 #' @param verbose Logical. If `TRUE`, compiler and linker output is printed
 #'   to the R console.
 #'
-#' @param cores Integer. Number of CPU cores used for parallel compilation
-#'   of individual source files into object files. Parallel compilation is
-#'   supported on all major operating systems.
-#'
 #' @details
-#' Compilation proceeds in two stages. First, each C/C++ source file is
-#' compiled into an object file (`.o`), using parallel processing if enabled.
-#' Second, the object files are linked into one or multiple shared libraries,
-#' depending on whether `output` is specified. Any previously loaded shared
-#' objects with matching names are automatically unloaded before linking.
-#' The resulting shared libraries are loaded into the current R session upon
-#' successful compilation.
+#' Any previously loaded shared libraries with matching names are unloaded
+#' prior to linking. Successfully linked libraries are loaded automatically.
+#'
+#' When `output` is specified, the `modelname` of each input object is
+#' overwritten with `output` to ensure consistent symbol naming across all
+#' compiled routines. In addition, the attributes `sourcefiles` (C/C++
+#' source files) and `objfiles` (corresponding object files) are added to
+#' each object for diagnostic purposes.
 #'
 #' @return
-#' Invisibly returns `TRUE` if compilation succeeds.
+#' Invisibly returns `TRUE` if compilation and linking succeed.
+#'
+#' @examples
+#' \dontrun{
+#' ## Compile a single model into separate shared libraries
+#' x <- odemodel(reactions)
+#' compile(x)
+#'
+#' ## Compile multiple models into a single shared library
+#' compile(x, g, output = "combined")
+#' }
 #'
 #' @export
 compile <- function(..., output = NULL, args = NULL, cores = 1, verbose = FALSE) {
+  
   objects   <- list(...)
   obj.names <- as.character(substitute(list(...)))[-1]
+  if (!length(objects)) stop("No objects provided.")
+  
+  # --- helpers ---------------------------------------------------------------
+  Rbin <- shQuote(file.path(R.home("bin"), "R"))
+  cfg  <- function(x) system(paste(Rbin, "CMD config", x), intern = TRUE)
 
-  # --- collect all source files ------------------------------------------------
+  # --- collect source files --------------------------------------------------
   files <- NULL
   for (i in seq_along(objects)) {
     if (inherits(objects[[i]], c("obsfn", "parfn", "prdfn"))) {
-      filename  <- modelname(objects[[i]])
-      filename  <- outer(filename, c("", "_deriv", "_s", "_s2", "_sdcv", "_dfdx", "_dfdp"), paste0)
-      files.obj <- c(paste0(filename, ".c"), paste0(filename, ".cpp"))
-      files.obj <- files.obj[file.exists(files.obj)]
-      files     <- union(files, files.obj)
+      fn <- modelname(objects[[i]])
+      fn <- outer(
+        fn,
+        c("", "_deriv", "_s", "_s2", "_sdcv", "_dfdx", "_dfdp"),
+        paste0
+      )
+      f  <- c(paste0(fn, ".c"), paste0(fn, ".cpp"))
+      files <- union(files, f[file.exists(f)])
     }
   }
+  if (!length(files))
+    stop("No source files found.")
 
-  if (length(files) == 0)
-    stop("No source files found for compilation (no .c or .cpp files).")
+  roots <- sub("\\.(c|cpp)$", "", files)
+  so    <- .Platform$dynlib.ext
 
-  .so <- .Platform$dynlib.ext
+  has_c   <- any(grepl("\\.c$",   files, ignore.case = TRUE))
+  has_cxx <- any(grepl("\\.cpp$", files, ignore.case = TRUE))
 
-  # -- include and compiler flags -----------------------------------------------
-  include_flags <- c(paste0("-I", shQuote(system.file("include", package = "CppODE"))))
-  cxxflags <- if (Sys.info()[["sysname"]] == "Windows") {
-    "-std=c++20"
-  } else {
-    "-std=c++20 -fPIC"
-  }
+  # --- flags -----------------------------------------------------------------
+  opt <- if (is.null(args) || !nzchar(args)) "-O3 -DNDEBUG" else args
+  inc <- paste0("-I", shQuote(system.file("include", package = "CppODE")))
+  
+  cflags   <- if (.Platform$OS.type == "windows") opt else paste("-fPIC", opt)
+  cxxflags <- paste(
+    "-std=c++20",
+    if (.Platform$OS.type == "windows") opt else paste("-fPIC", opt)
+  )
 
   Sys.setenv(
-    PKG_CPPFLAGS = paste(include_flags, collapse = " "),
+    PKG_CPPFLAGS = inc,
+    PKG_CFLAGS   = cflags,
     PKG_CXXFLAGS = cxxflags
   )
+  on.exit(Sys.setenv(PKG_CPPFLAGS="", PKG_CFLAGS="", PKG_CXXFLAGS=""), add = TRUE)
+  
+  # --- report toolchain ------------------------------------------------------
+  strip_std <- function(x) trimws(gsub("(^| )-std=[^ ]+", "", x))
+  get_std   <- function(x) if (grepl("-std=", x)) sub(".*-std=([^ ]+).*", "\\1", x) else NA
+  
+  if (has_c) {
+    std <- get_std(cflags)
+    cat(sprintf(
+      "using C compiler:   %s%s [%s]\n",
+      strip_std(cfg("CC")),
+      if (!is.na(std)) sprintf(" (standard: %s)", std) else "",
+      trimws(gsub("(^| )-std=[^ ]+", "", cflags))
+    ))
+  }
 
-  # -- set automatic optimization flags -----------------------------------------
-  optflags <- if (is.null(args) || !nzchar(args)) "-O3 -DNDEBUG" else args
+  if (has_cxx) {
+    std <- get_std(cxxflags)
+    cat(sprintf(
+      "using C++ compiler: %s%s [%s]\n",
+      strip_std(cfg("CXX")),
+      if (!is.na(std)) sprintf(" (standard: %s)", std) else "",
+      trimws(gsub("(^| )-std=[^ ]+", "", cxxflags))
+    ))
+  }
 
-  # --- set up parallel backend if needed ---------------------------------------
+  # --- parallel backend (foreach) --------------------------------------------
+  `%doit%` <- foreach::`%do%`
   if (cores > 1) {
-    if (Sys.info()[["sysname"]] == "Windows") {
+    if (.Platform$OS.type == "windows") {
       cl <- parallel::makeCluster(cores)
+      on.exit(parallel::stopCluster(cl), add = TRUE)
       doParallel::registerDoParallel(cl)
-      parallel::clusterCall(cl, function(x) .libPaths(x), .libPaths())
     } else {
       doParallel::registerDoParallel(cores = cores)
+      on.exit(doParallel::stopImplicitCluster(), add = TRUE)
     }
-    `%mydo%` <- foreach::`%dopar%`
-  } else {
-    `%mydo%` <- foreach::`%do%`
+    `%doit%` <- foreach::`%dopar%`
   }
 
-  # --- unload previously loaded libs -------------------------------------------
-  all_roots <- unique(sub("\\.(c|cpp)$", "", basename(files), ignore.case = TRUE))
-  for (r in all_roots) {
-    try(dyn.unload(paste0(r, .so)), silent = TRUE)
-  }
-  if (!is.null(output)) {
-    try(dyn.unload(paste0(output, .so)), silent = TRUE)
-  }
-  
-  Rbin <- shQuote(file.path(R.home("bin"), "R"))
-  obj_files <- sub("\\.(c|cpp)$", ".o", files, ignore.case = TRUE)
+  # --- unload old libs --------------------------------------------------------
+  invisible(lapply(c(roots, output), function(r)
+    if (!is.null(r)) try(dyn.unload(paste0(r, so)), silent = TRUE)
+  ))
 
-  # --- compile to object files in parallel -------------------------------------
-  foreach::foreach(i = seq_along(files)) %mydo% {
-    if (file.exists(obj_files[i])) file.remove(obj_files[i])
-    cmd <- paste(Rbin, "CMD SHLIB -c", shQuote(files[i]), optflags)
-    system(cmd, intern = !verbose)
+  # --- compile ----------------------------------------------------------------
+  foreach::foreach(i = seq_along(files)) %doit% {
+    out <- system(paste(Rbin, "CMD COMPILE", shQuote(files[i])), intern = TRUE)
+    if (verbose) cat(out, sep = "\n")
   }
 
-  if (cores > 1 && Sys.info()[["sysname"]] == "Windows") {
-    parallel::stopCluster(cl)
-  }
-  
-  # --- link --------------------------------------------------------------------
+  # --- link -------------------------------------------------------------------
   if (is.null(output)) {
-    # Separate shared libs
-    for (i in seq_along(files)) {
-      ofile <- paste0(all_roots[i], .so)
-      cmd <- paste(Rbin, "CMD SHLIB", shQuote(obj_files[i]), "-o", shQuote(ofile), optflags)
-      system(cmd, intern = !verbose)
-      dyn.load(ofile)
+    
+    ## set metadata for each object
+    for (i in seq_along(objects)) {
+      src <- files[grepl(paste0("^", modelname(objects[[i]])), files)]
+      obj <- sub("\\.(c|cpp)$", ".o", src)
+      attr(objects[[i]], "sourcefiles") <- src
+      attr(objects[[i]], "objfiles")    <- obj
     }
+    
+    ## load individual shared libraries
+    for (r in roots)
+      dyn.load(paste0(r, so))
+    
   } else {
-    # Combined shared lib
+    
     for (i in seq_along(objects)) {
-      eval(parse(text = sprintf("modelname(%s) <<- '%s'", obj.names[i], output)))
-      # Get only the .o files that belong to this object
-      obj_modelname <- modelname(objects[[i]])
-      obj_o <- obj_files[grepl(paste0("^", obj_modelname), basename(obj_files))]
-      eval(parse(text = sprintf("attr(%s, 'objfiles') <<- obj_o", obj.names[i])))
+      eval(parse(
+        text = paste0("modelname(", obj.names[i], ") <<- '", output, "'")
+      ))
+      src <- files[grepl(paste0("^", output), files)]
+      obj <- sub("\\.(c|cpp)$", ".o", src)
+      attr(objects[[i]], "sourcefiles") <- src
+      attr(objects[[i]], "objfiles")    <- obj
     }
 
-    cmd <- paste(Rbin, "CMD SHLIB", paste(shQuote(obj_files), collapse = " "), 
-                 "-o", shQuote(paste0(output, .so)), optflags)
-    system(cmd, intern = !verbose)
-    dyn.load(paste0(output, .so))
+    out <- system(paste(
+      Rbin, "CMD SHLIB",
+      paste(shQuote(sub("\\.(c|cpp)$", ".o", files)), collapse = " "),
+      "-o", paste0(output, so),
+      opt
+    ), intern = TRUE)
+    
+    if (verbose) cat(out, sep = "\n")
+    
+    dyn.load(paste0(output, so))
   }
 
   invisible(TRUE)
 }
 
 
+
+#' Get objfiles attribute
+#'
+#' @description The objfiles attribute contains the paths to compiled object files
+#' associated with a dMod function object.
+#'
+#' @param ... objects of type `prdfn`, `parfn`, `objfn`
+#' @return character vector of object file paths
+#'
+#' @export
+getObjfiles <- function(...) {
+  Reduce("union", lapply(list(...), function(x) attr(x, "objfiles")))
+}
+
+
+#' Get sourcefiles attribute
+#'
+#' @description
+#' The `sourcefiles` attribute contains the paths to C or C++ source files
+#' associated with a compiled dMod function object.
+#'
+#' @param ... Objects of type `prdfn`, `parfn`, or `obsfn`.
+#'
+#' @return
+#' A character vector of source file paths.
+#'
+#' @export
+getSourcefiles <- function(...) {
+  Reduce("union", lapply(list(...), function(x) attr(x, "sourcefiles")))
+}
+
+
+
+
 #' Determine loaded DLLs available in working directory
 #' 
 #' @return Character vector with the names of the loaded DLLs available in the working directory
@@ -598,12 +672,7 @@ loadDLL <- function(...) {
     try(dyn.unload(f), silent = TRUE)
     dyn.load(f)
   }
-  
-  
   message("The following local files were dynamically loaded: ", paste(files, collapse = ", "))
-  
-  
-  
 }