multicore/0000755000175100001440000000000011632040137012270 5ustar hornikusersmulticore/NEWS0000644000175100001440000000707611632020422012774 0ustar hornikusers NEWS/ChangeLog for multicore ------------------------------ 0.1-7 2011-09-07 o fix a bug introduced in 0.1-6 error checking for non-pre-scheduled jobs 0.1-6 2011-09-02 o mclapply() will issue a warning if any of the results is of the class "try-error". For prescheduled calls the warning will include the index of the core(s) that failed - to facilitate debugging of the user code. o minor performance improvements were made by creating results lists in C code and by resolving all native routines at load time. o bugfix: errors in prescheduled mclapply could result in incorrectly returned objects o bugfix: parallel() treated raw vector results as the result of serialized objects - thus arbitrary raw vectors were not alowed. (Thanks to Jeroen Ooms for reporting) 0.1-5 2011-03-09 o fix an issue in mclapply() and mc.prechedule = FALSE when NULL results are involved (thanks to Ralf Tautenhahn for reporting) 0.1-4 2011-02-11 o added (experimental) support for Windows Note: it (sort of) works on Windows 2k and XP only. Vista and Windows 7 is not supported due to changes to the kernel. Since Vista it becomes increasingly unlikely that multicore will be possible on Windows in general. o added cores detection for FreeBSD (thanks to Gunnar Schaefer) o added pvec() function which splits up the call of a vectorized map function across cores and re-combines them. It is useful for computation on large vectors. o added mc.cleanup argument (by default TRUE) which terminates child processes in the case of user interrupt (or error) in the master process. o children() allows to check the status of a subset of active processes using the select argument. o multicore now attempts to automatically disable event loop processing on Mac OS X in forked children. For Quartz Cocoa event loop this requires R 2.12.2 or higher. This allows the use of multicore in R for Mac GUI. 0.1-3 2009-02-02 o simplify the internal management of child processes and consequently remove bugs that lead to poor feeding of cores in mclapply() when no precheduling was used 0.1-2 2009-01-09 o added mc.preschedule parameter to mclappy() which (if FALSE) allows on-demand distribution of FUN calls across cores. o added "silent" parmeter to parallel() and mclapply() suppressing output on stdout in child processes o added internal functions closeStdout(), closeStrerr(), closeFD(), closeAll(), isChild(), childrenDescriptors() and masterDescriptor() o selectChildren() implicitly checks for and removes zombies o removed spurious debugging output in mclapply() o fixed cases in which mclapply() would not preserve names o fixed child list management o in order to make sure that children cannot die before the master can collect results, children will specifically wait for the master to allow them to exit (SIGUSR1 is used for this purpose, so don't use it directly unless you want a child to exit even if the master didn't release it). 0.1-1 2009-01-03 o added name parameter to parallel(), accordingly collect() names the results if the job name is present o bug fix: collect() returned early if no jobs responded for a while o bug fix: internal list of children could get corrupted when a child was removed (all preceding children were removed as well) o added better debugging support. Set PKG_CFLAGS=-DMC_DEBUG to enable debugging output on stdout (it is purposefully not sent to the R console to prevent output processing issues in child processes) 0.1-0 2009-01-02 o initial release multicore/man/0000755000175100001440000000000011632020422013036 5ustar hornikusersmulticore/man/multicore.Rd0000644000175100001440000001075411632020422015337 0ustar hornikusers\name{multicore} \alias{multicore} \alias{process} \alias{childProcess} \alias{masterProcess} \alias{parallelJob} \title{ multicore R package for parallel processing of R code } \description{ \emph{multicore} is an R package that provides functions for parallel execution of R code on machines with multiple cores or CPUs. Unlike other parallel processing methods all jobs share the full state of R when spawned, so no data or code needs to be initialized. The actual spawning is very fast as well since no new R instance needs to be started. } \section{Pivotal functions}{ \code{\link{mclapply}} - parallelized version of \code{\link{lapply}} \code{\link{pvec}} - parallelization of vectorized functions \code{\link{parallel}} and \code{\link{collect}} - functions to evaluate R expressions in parallel and collect the results. } \section{Low-level functions}{ Those function should be used only by experienced users understanding the interaction of the master (parent) process and the child processes (jobs) as well as the system-level mechanics involved. See \code{\link{fork}} help page for the principles of forking parallel processes and system-level functions, \code{\link{children}} and \code{\link{sendMaster}} help pages for management and communication between the parent and child processes. } \section{Classes}{ \emph{multicore} defines a few informal (S3) classes: \code{process} is a list with a named entry \code{pid} containing the process ID. \code{childProcess} is a subclass of \code{process} representing a child process of the current R process. A child process is a special process that can send messages to the parent process. The list may contain additional entries for IPC (more precisely file descriptors), however those are considered internal. \code{masterProcess} is a subclass of \code{process} representing a handle that is passed to a child process by \code{\link{fork}}. \code{parallelJob} is a subclass of \code{childProcess} representing a child process created using the \code{\link{parallel}} function. It may (optionally) contain a \code{name} entry -- a character vector of the length one as the name of the job. } \section{Options}{ By default functions that spawn jobs across cores use the \code{"cores"} option (see \code{\link{options}}) to determine how many cores (or CPUs) will be used (unless specified directly). If this option is not set, \emph{multicore} uses by default as many cores as there are available. (Note: \emph{cores} in this document refer to virtual cores. Modern CPUs can have more virutal cores than physical cores to accommodate simultaneous multithreading. For example, a machine with two quad-core Xeon W5590 processors has combined eight physical cores but 16 virtual cores. Also note that it is often beneficial to schedule more tasks than cores.) The number of available cores is determined on startup using the (non-exported) \code{detectCores()} function. It should work on most commonly used unix systems (Mac OS X, Linux, Solaris and IRIX), but there is no standard way of determining the number of cores, so please contact me (with \code{sessionInfo()} output and the test) if you have tests for other platforms. If in doubt, use \code{multicore:::detectCores(all.tests=TRUE)} to see whether your platform is covered by one of the already existing tests. If multicore cannot determine the number of cores (the above returns \code{NA}), it will default to 8 (which should be fine for most modern desktop systems). } \section{Warning}{ \emph{multicore} uses the \code{fork} system call to spawn a copy of the current process which performs the compultations in parallel. Modern operating systems use copy-on-write approach which makes this so appealing for parallel computation since only objects modified during the computation will be actually copied and all other memory is directly shared. However, the copy shares everything including any user interface elements. This can cause havoc since let's say one window now suddenly belongs to two processes. Therefore \emph{multicore} should be preferrably used in console R and code executed in parallel may never use GUIs or on-screen devices. An (experimental) way to avoid some such problems in some GUI environments (those using pipes or sockets) is to use \code{multicore:::closeAll()} in each child process immediately after it is spawned. } \seealso{ \code{\link{parallel}}, \code{\link{mclapply}}, \code{\link{fork}}, \code{\link{sendMaster}}, \code{\link{children}} and \code{\link{signals}} } \author{Simon Urbanek} \keyword{interface} multicore/man/fork.Rd0000644000175100001440000000545311632020422014275 0ustar hornikusers\name{fork} \alias{fork} \alias{exit} \title{ Fork a copy of the current R process } \description{ \code{fork} creates a new child process as a copy of the current R process \code{exit} closes the current child process, informing the master process as necessary } \section{Warning}{ This is a very low-level API for expert use only. If you are interested in user-level parallel execution use \code{\link{mclapply}}, \code{\link{parallel}} and friends instead. } \usage{ fork() exit(exit.code = 0L, send = NULL) } \arguments{ \item{exit.code}{process exit code. Currently it is not used by multicore, but other applciations might. By convention 0 signifies clean exit, 1 an error.} \item{send}{if not \code{NULL} send this data before exiting (equivalent to using \code{\link{sendMaster}})} } \value{ \code{fork} returns an object of the class \code{childProcess} (to the master) and \code{masterProcess} (to the child). \code{exit} never returns } \details{ The \code{fork} function provides an interface to the \code{fork} system call. In addition it sets up a pipe between the master and child process that can be used to send data from the child process to the master (see \code{\link{sendMaster}}) and child's stdin is re-mapped to another pipe held by the master process (see \code{link{sendChildStdin}}). If you are not familiar with the \code{fork} system call, do not use this function since it leads to very complex inter-process interactions among the R processes involved. In a nutshell \code{fork} spawns a copy (child) of the current process, that can work in parallel to the master (parent) process. At the point of forking both processes share exactly the same state including the workspace, global options, loaded packages etc. Forking is relatively cheap in modern operating systems and no real copy of the used memory is created, instead both processes share the same memory and only modified parts are copied. This makes \code{fork} an ideal tool for parallel processing since there is no need to setup the parallel working environment, data and code is shared automatically from the start. It is \emph{strongly discouraged} to use \code{fork} in GUI or embedded environments, because it leads to several processes sharing the same GUI which will likely cause chaos (and possibly crashes). Child processes should never use on-screen graphics devices. } \note{ Windows opearting system lacks the \code{fork} system call so it cannot be used with multicore. } \seealso{ \code{\link{parallel}}, \code{\link{sendMaster}} } \examples{ p <- fork() if (inherits(p, "masterProcess")) { cat("I'm a child! ", Sys.getpid(), "\n") exit(,"I was a child") } cat("I'm the master\n") unserialize(readChildren(1.5)) } \author{Simon Urbanek} \keyword{interface} multicore/man/mclapply.Rd0000644000175100001440000001004611632020422015147 0ustar hornikusers\name{mclapply} \alias{mclapply} \title{ Parallel version of lapply } \description{ \code{mclapply} is a parallelized version of \code{\link{lapply}}, it returns a list of the same length as \code{X}, each element of which is the result of applying \code{FUN} to the corresponding element of \code{X}. } \usage{ mclapply(X, FUN, ..., mc.preschedule = TRUE, mc.set.seed = TRUE, mc.silent = FALSE, mc.cores = getOption("cores"), mc.cleanup = TRUE) } \arguments{ \item{X}{a vector (atomic or list) or an expressions vector. Other objects (including classed objects) will be coerced by \code{\link{as.list}}.} \item{FUN}{the function to be applied to each element of \code{X}} \item{...}{optional arguments to \code{FUN}} \item{mc.preschedule}{if set to \code{TRUE} then the computation is first divided to (at most) as many jobs are there are cores and then the jobs are started, each job possibly covering more than one value. If set to \code{FALSE} then one job is spawned for each value of \code{X} sequentially (if used with \code{mc.set.seed=FALSE} then random number sequences will be identical for all values). The former is better for short computations or large number of values in \code{X}, the latter is better for jobs that have high variance of completion time and not too many values of \code{X}.} \item{mc.set.seed}{if set to \code{TRUE} then each parallel process first sets its seed to something different from other processes. Otherwise all processes start with the same (namely current) seed.} \item{mc.silent}{if set to \code{TRUE} then all output on stdout will be suppressed for all parallel processes spawned (stderr is not affected).} \item{mc.cores}{The number of cores to use, i.e. how many processes will be spawned (at most)} \item{mc.cleanup}{if set to \code{TRUE} then all children that have been spawned by this function will be killed (by sending \code{SIGTERM}) before this function returns. Under normal circumstances \code{mclapply} waits for the children to deliver results, so this option usually has only effect when \code{mclapply} is interrupted. If set to \code{FALSE} then child processes are collected, but not forcefully terminated. As a special case this argument can be set to the signal value that should be used to kill the children instead of \code{SIGTERM}.} } \value{ A list. } \details{ \code{mclapply} is a parallelized version of \code{lapply}, but there is an important difference: \code{mclapply} does not affect the calling environment in any way, the only side-effect is the delivery of the result (with the exception of a fall-back to \code{lapply} when there is only one core). By default (\code{mc.preschedule=TRUE}) the input vector/list \code{X} is split into as many parts as there are cores (currently the values are spread across the cores sequentially, i.e. first value to core 1, second to core 2, ... (core + 1)-th value to core 1 etc.) and then one process is spawned to each core and the results are collected. Due to the parallel nature of the execution random numbers are not sequential (in the random number sequence) as they would be in \code{lapply}. They are sequential for each spawned process, but not all jobs as a whole. In addition, each process is running the job inside \code{try(..., silent=TRUE)} so if error occur they will be stored as \code{try-error} objects in the list. Note: the number of file descriptors is usually limited by the operating system, so you may have trouble using more than 100 cores or so (see \code{ulimit -n} or similar in your OS documentation) unless you raise the limit of permissible open file descriptors (fork will fail with "unable to create a pipe"). } \seealso{ \code{\link{parallel}}, \code{\link{collect}} } \examples{ mclapply(1:30, rnorm) # use the same random numbers for all values set.seed(1) mclapply(1:30, rnorm, mc.preschedule=FALSE, mc.set.seed=FALSE) # something a bit bigger - albeit still useless :P unlist(mclapply(1:32, function(x) sum(rnorm(1e7)))) } \author{Simon Urbanek} \keyword{interface} multicore/man/children.Rd0000644000175100001440000000616411632020422015124 0ustar hornikusers\name{children} \alias{children} \alias{readChild} \alias{readChildren} \alias{selectChildren} \alias{sendChildStdin} \alias{kill} \title{ Functions for management of parallel children processes } \description{ \code{children} returns currently active children \code{readChild} reads data from a given child process \code{selectChildren} checks children for available data \code{readChildren} checks children for available data and reads from the first child that has available data \code{sendChildStdin} sends string (or data) to child's standard input \code{kill} sends a signal to a child process } \section{Warning}{ This is a very low-level API for expert use only. If you are interested in user-level parallel execution use \code{\link{mclapply}}, \code{\link{parallel}} and friends instead. } \usage{ children(select) readChild(child) readChildren(timeout = 0) selectChildren(children = NULL, timeout = 0) sendChildStdin(child, what) kill(process, signal = SIGINT) } \arguments{ \item{select}{if omitted, all active children are returned, otherwise \code{select} should be a list of processes and only those form the list that are active will be returned.} \item{child}{child process (object of the class \code{childProcess}) or a process ID (pid)} \item{timeout}{timeout (in seconds, fractions supported) to wait before giving up. Negative numbers mean wait indefinitely (strongly discouraged as it blocks R and may be removed in the future).} \item{children}{list of child processes or a single child process object or a vector of process IDs or \code{NULL}. If \code{NULL} behaves as if all currently known children were supplied.} \item{what}{character or raw vector. In the former case elements are collapsed using the newline chracter. (But no trailing newline is added at the end!)} \item{process}{process (object of the class \code{process}) or a process ID (pid)} \item{signal}{signal to send (one of \code{SIG...} constants -- see \code{\link{signals}} -- or a valid integer signal number)} } \value{ \code{children} returns a list of child processes (or an empty list) \code{readChild} and \code{readChildren} return a raw vector with a \code{"pid"} attribute if data were available, integer vector of length one with the process ID if a child terminated or \code{NULL} if the child no longer exists (no children at all for \code{readChildren}). \code{selectChildren} returns \code{TRUE} is the timeout was reached, \code{FALSE} if an error occurred (e.g. if the master process was interrupted) or an integer vector of process IDs with children that have data available. \code{sendChildStdin} sends given content to the standard input (stdin) of the child process. Note that if the master session was interactive, it will also be echoed on the standard output of the master process (unless disabled). The function is vector-compatible, so you can specify more than one child as a list or a vector of process IDs. \code{kill} returns \code{TRUE}. } \seealso{ \code{\link{fork}}, \code{\link{sendMaster}}, \code{\link{parallel}}, \code{\link{mclapply}} } \author{Simon Urbanek} \keyword{interface} multicore/man/sendMaster.Rd0000644000175100001440000000146711632020422015442 0ustar hornikusers\name{sendMaster} \alias{sendMaster} \title{ Sends data from the child to to the master process } \description{ \code{sendMaster} Sends data from the child to to the master process } \usage{ sendMaster(what) } \arguments{ \item{what}{data to send to the master process. If \code{what} is not a raw vetor, \code{what} will be serialized into a raw vector. Do NOT send an empty raw vector - it is reserved for internal use.} } \value{ returns \code{TRUE} } \details{ Any child process (created by \code{\link{fork}} directly or by \code{\link{parallel}} indirectly) can send data to the parent (master) process. Usually this is used to deliver results from the parallel child processes to the master process. } \seealso{ \code{\link{parallel}}, \code{\link{fork}} } \author{Simon Urbanek} \keyword{interface} multicore/man/signals.Rd0000644000175100001440000000162711632020422014773 0ustar hornikusers\name{signals} \alias{signals} \alias{SIGALRM} \alias{SIGCHLD} \alias{SIGHUP} \alias{SIGINFO} \alias{SIGINT} \alias{SIGKILL} \alias{SIGQUIT} \alias{SIGSTOP} \alias{SIGTERM} \alias{SIGUSR1} \alias{SIGUSR2} \title{ Signal constants (subset) } \description{ \code{SIGALRM} alarm clock \code{SIGCHLD} to parent on child stop or exit \code{SIGHUP} hangup \code{SIGINFO} information request \code{SIGINT} interrupt \code{SIGKILL} kill (cannot be caught or ignored) \code{SIGQUIT} quit \code{SIGSTOP} sendable stop signal not from tty \code{SIGTERM} software termination signal from kill \code{SIGUSR1} user defined signal 1 \code{SIGUSR2} user defined signal 2 } \details{ See \code{man signal} in your OS for details. The above codes can be used in conjunction with the \code{\link{kill}} function to send signals to processes. } \seealso{ \code{\link{kill}} } \author{Simon Urbanek} \keyword{interface} multicore/man/parallel.Rd0000644000175100001440000001012611632020422015121 0ustar hornikusers\name{parallel} \alias{parallel} \alias{collect} \alias{mcparallel} \title{ Evaluate an expression asynchronously in a separate process } \description{ \code{parallel} starts a parallel process which evaluates the given expression. \code{mcparallel} is a synonym for \code{parallel} that can be used at top level if \code{parallel} is masked by other packages. It should not be used in other packages since it's just a shortcut for importing \code{multicore::parallel}. \code{collect} collects results from parallel processes. } \usage{ parallel(expr, name, mc.set.seed = FALSE, silent = FALSE) mcparallel(expr, name, mc.set.seed = FALSE, silent = FALSE) collect(jobs, wait = TRUE, timeout = 0, intermediate = FALSE) } \arguments{ \item{expr}{expression to evaluate (do \emph{not} use any on-screen devices or GUI elements in this code)} \item{name}{an optional name (character vector of length one) that can be associated with the job.} \item{mc.set.seed}{if set to \code{TRUE} then the random number generator is seeded such that it is different from any other process. Otherwise it will be the same as in the current R session.} \item{silent}{if set to \code{TRUE} then all output on stdout will be suppressed (stderr is not affected).} \item{jobs}{list of jobs (or a single job) to collect results for. Alternatively \code{jobs} can also be an integer vector of process IDs. If omitted \code{collect} will wait for all currently existing children.} \item{wait}{if set to \code{FALSE} it checks for any results that are available within \code{timeout} seconds from now, otherwise it waits for all specified jobs to finish.} \item{timeout}{timeout (in seconds) to check for job results - applies only if \code{wait} is \code{FALSE}.} \item{intermediate}{\code{FALSE} or a function which will be called while \code{collect} waits for results. The function will be called with one parameter which is the list of results received so far.} } \value{ \code{parallel} returns an object of the class \code{parallelJob} which is in turn a \code{childProcess}. \code{collect} returns any results that are available in a list. The results will have the same order as the specified jobs. If there are multiple jobs and a job has a name it will be used to name the result, otherwise its process ID will be used. } \details{ \code{parallel} evaluates the \code{expr} expression in parallel to the current R process. Everything is shared read-only (or in fact copy-on-write) between the parallel process and the current process, i.e. no side-effects of the expression affect the main process. The result of the parallel execution can be collected using \code{collect} function. \code{collect} function collects any available results from parallel jobs (or in fact any child process). If \code{wait} is \code{TRUE} then \code{collect} waits for all specified jobs to finish before returning a list containing the last reported result for each job. If \code{wait} is \code{FALSE} then \code{collect} merely checks for any results available at the moment and will not wait for jobs to finish. If \code{jobs} is specified, jobs not listed there will not be affected or acted upon. Note: If \code{expr} uses low-level \code{multicore} functions such as \code{\link{sendMaster}} a single job can deliver results multiple times and it is the responsibility of the user to interpret them correctly. \code{collect} will return \code{NULL} for a terminating job that has sent its results already after which the job is no longer available. } \seealso{ \code{\link{mclapply}}, \code{\link{sendMaster}} } \examples{ p <- parallel(1:10) q <- parallel(1:20) collect(list(p, q)) # wait for jobs to finish and collect all results p <- parallel(1:10) collect(p, wait=FALSE, 10) # will retrieve the result (since it's fast) collect(p, wait=FALSE) # will signal the job as terminating collect(p, wait=FALSE) # there is no such job # a naive parallelized lapply can be created using parallel alone: jobs <- lapply(1:10, function(x) parallel(rnorm(x), name=x)) collect(jobs) } \author{Simon Urbanek} \keyword{interface} multicore/man/process.Rd0000644000175100001440000000143711632020422015010 0ustar hornikusers\name{process} \alias{processID} \alias{print.process} \title{ Function to query objects of the class process } \description{ \code{processID} returns the process IDs for the given processes. It raises an error if \code{process} is not an object of the class \code{\link{process}} or a list of such objects. \code{print} methods shows the process ID and its class name. } \usage{ processID(process) \method{print}{process}(x, \dots) } \arguments{ \item{process}{process (object of the class \code{process}) or a list of such objects.} \item{x}{process to print} \item{...}{ignored} } \value{ \code{processID} returns an integer vector contatining the process IDs. \code{print} returns \code{NULL} invisibly } \seealso{ \code{\link{fork}} } \author{Simon Urbanek} \keyword{interface} multicore/man/pvec.Rd0000644000175100001440000000753211632020422014271 0ustar hornikusers\name{pvec} \alias{pvec} \title{ Parallelize a vector map function } \description{ \code{pvec} parellelizes the execution of a function on vector elements by splitting the vector and submitting each part to one core. The function must be a vectorized map, i.e. it takes a vector input and creates a vector output of exactly the same length as the input which doesn't depend on the partition of the vector. } \usage{ pvec(v, FUN, ..., mc.set.seed = TRUE, mc.silent = FALSE, mc.cores = getOption("cores"), mc.cleanup = TRUE) } \arguments{ \item{v}{vector to operate on} \item{FUN}{function to call on each part of the vector} \item{\dots}{any further arguments passed to \code{FUN} after the vector} \item{mc.set.seed}{if set to \code{TRUE} then each parallel process first sets its seed to something different from other processes. Otherwise all processes start with the same (namely current) seed.} \item{mc.silent}{if set to \code{TRUE} then all output on stdout will be suppressed for all parallel processes spawned (stderr is not affected).} \item{mc.cores}{The number of cores to use, i.e. how many processes will be spawned (at most)} \item{mc.cleanup}{flag specifying whether children should be terminated when the master is aborted (see description of this argument in \code{\link{mclapply}} for details)} } \details{ \code{pvec} parallelizes \code{FUN(x, ...)} where \code{FUN} is a function that returns a vector of the same length as \code{x}. \code{FUN} must also be pure (i.e., without side-effects) since side-effects are not collected from the parallel processes. The vector is split into nearly identically sized subvectors on which \code{FUN} is run. Although it is in principle possible to use functions that are not necessarily maps, the interpretation would be case-specific as the splitting is in theory arbitrary and a warning is given in such cases. The major difference between \code{pvec} and \code{\link{mclapply}} is that \code{mclapply} will run \code{FUN} on each element separately whereas \code{pvec} assumes that \code{c(FUN(x[1]), FUN(x[2]))} is equivalent to \code{FUN(x[1:2])} and thus will split into as many calls to \code{FUN} as there are cores, each handling a subset vector. This makes it much more efficient than \code{mclapply} but requires the above assumption on \code{FUN}. } \value{ The result of the computation - in a successful case it should be of the same length as \code{v}. If an error ocurred or the function was not a map the result may be shorter and a warning is given. } %\references{ %} %\author{ %} \note{ Due to the nature of the parallelization error handling does not follow the usual rules since errors will be returned as strings and killed child processes will show up simply as non-existent data. Therefore it is the responsibiliy of the user to check the length of the result to make sure it is of the correct size. \code{pvec} raises a warning if that is the case since it dos not know whether such outcome is intentional or not. } \seealso{ \code{\link{parallel}}, \code{\link{mclapply}} } \examples{ x <- pvec(1:1000, sqrt) stopifnot(all(x == sqrt(1:1000))) # a common use is to convert dates to unix time in large datasets # as that is an awfully slow operation # so let's get some random dates first dates <- sprintf('\%04d-\%02d-\%02d', as.integer(2000+rnorm(1e5)), as.integer(runif(1e5,1,12)), as.integer(runif(1e5,1,28))) # this takes 4s on a 2.6GHz Mac Pro system.time(a <- as.POSIXct(dates)) # this takes 0.5s on the same machine (8 cores, 16 HT) system.time(b <- pvec(dates, as.POSIXct)) stopifnot(all(a == b)) # using mclapply for this is much slower because each value # will require a separate call to as.POSIXct() system.time(c <- unlist(mclapply(dates, as.POSIXct))) } \keyword{interface} multicore/R/0000755000175100001440000000000011632020421012463 5ustar hornikusersmulticore/R/parallel.R0000644000175100001440000000360411632020421014405 0ustar hornikusersparallel <- function(expr, name, mc.set.seed=FALSE, silent=FALSE) { f <- fork() env <- parent.frame() if (inherits(f, "masterProcess")) { on.exit(exit(1, structure("fatal error in wrapper code",class="try-error"))) if (isTRUE(mc.set.seed)) set.seed(Sys.getpid()) if (isTRUE(silent)) closeStdout() sendMaster(serialize(try(eval(expr, env), silent=TRUE), NULL, FALSE)) exit(0) } if (!missing(name) && !is.null(name)) f$name <- as.character(name)[1] class(f) <- c("parallelJob", class(f)) f } # synonym for parallel in case someone masks us mcparallel <- parallel collect <- function(jobs, wait=TRUE, timeout=0, intermediate=FALSE) { if (missing(jobs)) jobs <- children() if (!length(jobs)) return (NULL) if (isTRUE(intermediate)) intermediate <- str if (!wait) { s <- selectChildren(jobs, timeout) if (is.logical(s) || !length(s)) return(NULL) lapply(s, function(x) { r <- readChild(x); if (is.raw(r)) unserialize(r) else NULL }) } else { pids <- if (inherits(jobs, "process") || is.list(jobs)) processID(jobs) else jobs if (!length(pids)) return(NULL) if (!is.numeric(pids)) stop("invalid jobs argument") pids <- as.integer(pids) pnames <- as.character(pids) if (!inherits(jobs, "process") && is.list(jobs)) for(i in seq(jobs)) if (!is.null(jobs[[i]]$name)) pnames[i] <- as.character(jobs[[i]]$name) res <- lapply(pids, function(x) NULL) names(res) <- pnames fin <- rep(FALSE, length(jobs)) while (!all(fin)) { s <- selectChildren(pids, 0.5) if (is.integer(s)) { for (pid in s) { r <- readChild(pid) if (is.integer(r) || is.null(r)) fin[pid==pids] <- TRUE if (is.raw(r)) res[[which(pid==pids)]] <- unserialize(r) } if (is.function(intermediate)) intermediate(res) } else if (all(is.na(match(pids, processID(children()))))) break } res } } multicore/R/zzz.R0000644000175100001440000000321011632020421013437 0ustar hornikusers# this envoronment holds any volatile variables we may want to keep inside the package volatile <- new.env(TRUE, emptyenv()) # detect the number of [virtual] CPUs (cores) detectCores <- function(all.tests = FALSE) { # feel free to add tests - those are the only ones I could test [SU] systems <- list(darwin = "/usr/sbin/sysctl -n hw.ncpu 2>/dev/null", freebsd = "/sbin/sysctl -n hw.ncpu 2>/dev/null", linux = "grep processor /proc/cpuinfo 2>/dev/null|wc -l", irix = c("hinv |grep Processors|sed 's: .*::'", "hinv|grep '^Processor '|wc -l"), solaris = "/usr/sbin/psrinfo -v|grep 'Status of.*processor'|wc -l") for (i in seq(systems)) if(all.tests || length(grep(paste("^", names(systems)[i], sep=''), R.version$os))) for (cmd in systems[i]) { a <- gsub("^ +","",system(cmd, TRUE)[1]) if (length(grep("^[1-9]", a))) return(as.integer(a)) } NA } .register.addr <- c("mc_fork", "read_children", "read_child", "select_children", "rm_child", "send_master", "send_child_stdin", "mc_exit", "mc_children", "mc_fds", "mc_master_fd", "mc_is_child", "close_stdout", "close_stderr", "close_fds", "create_list", "mc_kill") .onLoad <- function(libname, pkgname) { cores <- detectCores() volatile$detectedCoresSuccess <- !is.na(cores) if (is.na(cores)) cores <- 8L # a fallback expecting higher-end desktop ... volatile$detectedCores <- cores ## register all native routines env <- topenv() addr <- getNativeSymbolInfo(.register.addr, pkgname) for (name in .register.addr) env[[name]] <- addr[[name]]$address TRUE } multicore/R/pvec.R0000644000175100001440000000257411632020421013553 0ustar hornikuserspvec <- function(v, FUN, ..., mc.set.seed=TRUE, mc.silent=FALSE, mc.cores=getOption("cores"), mc.cleanup=TRUE) { if (!is.vector(v)) stop("v must be a vector") env <- parent.frame() cores <- mc.cores if (is.null(cores)) cores <- volatile$detectedCores cores <- as.integer(cores) n <- length(v) l <- if (n < cores) as.list(v) else { # compute the scheduling, making it as fair as possible il <- as.integer(n / cores) xc <- n - il * cores sl <- rep(il, cores) if (xc) sl[1:xc] <- il + 1 si <- cumsum(c(1L, sl)) se <- si + c(sl, 0L) - 1L lapply(1:cores, function(ix) v[si[ix]:se[ix]]) } jobs <- NULL cleanup <- function() { ## kill children if cleanup is requested if (length(jobs) && mc.cleanup) { ## first take care of uncollected children collect(children(jobs), FALSE) kill(children(jobs), if (is.integer(mc.cleanup)) mc.cleanup else SIGTERM) collect(children(jobs)) } if (length(jobs)) { ## just in case there are zombies collect(children(jobs), FALSE) } } on.exit(cleanup()) FUN <- match.fun(FUN) jobs <- lapply(seq(cores), function(i) parallel(FUN(l[[i]], ...), name=i, mc.set.seed=mc.set.seed, silent=mc.silent)) res <- collect(jobs) names(res) <- NULL res <- do.call(c, res) if (length(res) != n) warning("some results may be missing, folded or caused an error") res } multicore/R/mclapply.R0000644000175100001440000001151211632020421014427 0ustar hornikusersmclapply <- function(X, FUN, ..., mc.preschedule=TRUE, mc.set.seed=TRUE, mc.silent=FALSE, mc.cores=getOption("cores"), mc.cleanup=TRUE) { env <- parent.frame() cores <- mc.cores if (is.null(cores)) cores <- volatile$detectedCores cores <- as.integer(cores) jobs <- list() cleanup <- function() { # kill children if cleanup is requested if (length(jobs) && mc.cleanup) { ## first take care of uncollected children collect(children(jobs), FALSE) kill(children(jobs), if (is.integer(mc.cleanup)) mc.cleanup else SIGTERM) collect(children(jobs)) } if (length(jobs)) { ## just in case there are zombies collect(children(jobs), FALSE) } } on.exit(cleanup()) if (!mc.preschedule) { # sequential (non-scheduled) FUN <- match.fun(FUN) if (length(X) <= cores) { # all-out, we can use one-shot parallel jobs <- lapply(seq(X), function(i) parallel(FUN(X[[i]], ...), name=names(X)[i], mc.set.seed=mc.set.seed, silent=mc.silent)) res <- collect(jobs) if (length(res) == length(X)) names(res) <- names(X) has.errors <- sum(sapply(res, inherits, "try-error")) if (has.errors) warning(has.errors, "of all function calls resulted in an error") return(res) } else { # more complicated, we have to wait for jobs selectively sx <- seq(X) res <- .Call(create_list, length(sx)) names(res) <- names(X) ent <- rep(FALSE, length(X)) # values entered (scheduled) fin <- rep(FALSE, length(X)) # values finished jobid <- 1:cores jobs <- lapply(jobid, function(i) parallel(FUN(X[[i]], ...), mc.set.seed=mc.set.seed, silent=mc.silent)) jobsp <- processID(jobs) ent[jobid] <- TRUE has.errors <- 0L while (!all(fin)) { s <- selectChildren(jobs, 0.5) if (is.null(s)) break # no children -> no hope if (is.integer(s)) for (ch in s) { ji <- which(jobsp == ch)[1] ci <- jobid[ji] r <- readChild(ch) if (is.raw(r)) { child.res <- unserialize(r) if (inherits(child.res, "try-error")) has.errors <- has.errors + 1L # we can't jsut assign it since a NULL assignment would remove it from the list if (!is.null(child.res)) res[[ci]] <- child.res } else { fin[ci] <- TRUE # cat("fin: "); print(fin) # cat("res: "); print(unlist(lapply(res, is.null))) if (!all(ent)) { # still something to do, spawn a new job nexti <- which(!ent)[1] jobid[ji] <- nexti jobs[[ji]] <- parallel(FUN(X[[nexti]], ...), mc.set.seed=mc.set.seed, silent=mc.silent) jobsp[ji] <- processID(jobs[[ji]]) ent[nexti] <- TRUE } } } } if (has.errors) warning(has.errors, "of all function calls resulted in an error") return(res) } } if (length(X) < cores) cores <- length(X) if (cores < 2) return(lapply(X, FUN, ...)) sindex <- lapply(1:cores, function(i) seq(i,length(X), by=cores)) schedule <- lapply(1:cores, function(i) X[seq(i,length(X), by=cores)]) ch <- list() res <- .Call(create_list, length(X)) names(res) <- names(X) cp <- rep(0L, cores) fin <- rep(FALSE, cores) dr <- rep(FALSE, cores) inner.do <- function(core) { S <- schedule[[core]] f <- fork() if (inherits(f, "masterProcess")) { # child process on.exit(exit(1,structure("fatal error in wrapper code",class="try-error"))) if (isTRUE(mc.set.seed)) set.seed(Sys.getpid()) if (isTRUE(mc.silent)) closeStdout() sendMaster(try(lapply(S, FUN, ...), silent=TRUE)) exit(0) } jobs[[core]] <<- ch[[core]] <<- f cp[core] <<- f$pid NULL } job.res <- lapply(1:cores, inner.do) ac <- cp[cp > 0] has.errors <- integer(0) while (!all(fin)) { s <- selectChildren(ac, 1) if (is.null(s)) break # no children -> no hope we get anything if (is.integer(s)) for (ch in s) { a <- readChild(ch) if (is.integer(a)) { core <- which(cp == a) fin[core] <- TRUE } else if (is.raw(a)) { core <- which(cp == attr(a, "pid")) ijr <- unserialize(a) if (inherits(ijr, "try-error")) { has.errors <- c(has.errors, core) ijr <- rep(list(ijr), length(schedule[[core]])) } job.res[[core]] <- ijr dr[core] <- TRUE } } } for (i in 1:cores) res[sindex[[i]]] <- job.res[[i]] if (length(has.errors)) { if (length(has.errors) == cores) warning("all scheduled cores encountered errors in user code") else if (length(has.errors) == 1L) warning("scheduled core ", has.errors, " encountered error in user code, all values of the job will be affected") else warning("scheduled cores ",paste(has.errors, sep=", "), " encountered errors in user code, all values of the jobs will be affected") } res } #mcapply(1:4, function(i) i+1) multicore/R/fork.R0000644000175100001440000000651411632020421013555 0ustar hornikusers# --- multicore --- low-level functions --- # selected signals SIGHUP <- 1L SIGINT <- 2L SIGQUIT <- 3L SIGKILL <- 9L SIGTERM <- 15L SIGALRM <- 14L SIGSTOP <- 17L SIGCHLD <- 20L SIGINFO <- 29L SIGUSR1 <- 30L SIGUSR2 <- 31L fork <- function() { r <- .Call(mc_fork) structure(list(pid=r[1], fd=r[2:3]), class=c(ifelse(r[1]!=0L,"childProcess","masterProcess"),"process")) } readChildren <- function(timeout=0) .Call(read_children, as.double(timeout)) readChild <- function(child) { if (inherits(child, "process")) child <- processID(child) if (!is.numeric(child)) stop("invalid child argument") .Call(read_child, as.integer(child)) } selectChildren <- function(children=NULL, timeout=0) { if (!length(children)) children <- integer(0) if (inherits(children, "process")) children <- processID(children) if (is.list(children)) children <- unlist(lapply(children, function(x) if (inherits(x, "process")) x$pid else stop("children must be a list of processes or a single process"))) if (!is.numeric(children)) stop("children must be a list of processes or a single process") .Call(select_children, as.double(timeout), as.integer(children)) } rmChild <- function(child) { if (inherits(child, "process")) child <- processID(child) if (!is.numeric(child)) stop("invalid child argument") .Call(rm_child, as.integer(child)) } kill <- function(process, signal=SIGINT) { process <- processID(process) unlist(lapply(process, function(p) .Call(mc_kill, as.integer(p), as.integer(signal)))) } sendMaster <- function(what) { if (!is.raw(what)) what <- serialize(what, NULL, FALSE) .Call(send_master, what) } processID <- function(process) if (inherits(process, "process")) process$pid else if (is.list(process)) unlist(lapply(process, processID)) else stop("process must be of the class `process'") sendChildStdin <- function(child, what) { if (inherits(child, "process") || is.list(child)) child <- processID(child) if (!is.numeric(child) || !length(child)) stop("child must be a valid child process") child <- as.integer(child) if (is.character(what)) what <- charToRaw(paste(what, collapse='\n')) if (!is.raw(what)) stop("what must be a character or raw vector") unlist(lapply(child, function(p) .Call(send_child_stdin, p, what))) } exit <- function(exit.code=0L, send=NULL) { if (!is.null(send)) try(sendMaster(send), silent=TRUE) .Call(mc_exit, as.integer(exit.code)) } children <- function(select) { p <- .Call(mc_children) if (!missing(select)) p <- p[p %in% processID(select)] lapply(p, function(x) structure(list(pid=x), class=c("childProcess", "process"))) } childrenDescriptors <- function(index=0L) .Call(mc_fds, as.integer(index)) masterDescriptor <- function() .Call(mc_master_fd) isChild <- function() .Call(mc_is_child) # those could be really written as closeFD(1L) and closeFD(2L), but historically ... closeStdout <- function() .Call(close_stdout) closeStderr <- function() .Call(close_stderr) closeFD <- function(fds) .Call(close_fds, as.integer(fds)) closeAll <- function(includeStd=FALSE) { if (!isChild()) { warning("closeAll() is a no-op in the master process"); return(invisible(FALSE)) } fds <- masterDescriptor() if (identical(fds, -1L)) fds <- integer(0) if (includeStd) fds <- c(1L, 2L, fds) mf <- max(fds) + 16L # take a few more ... # close all but those that we actually use closeFD((1:mf)[-fds]) } multicore/R/print.R0000644000175100001440000000013711632020421013743 0ustar hornikusersprint.process <- function(x, ...) cat(paste(" ",class(x)[1],": processID=",x$pid,"\n",sep='')) multicore/NAMESPACE0000644000175100001440000000035511632020422013505 0ustar hornikusersexportPattern("^SIG") export(fork, readChild, readChildren, selectChildren, children, kill, exit, sendMaster, sendChildStdin, processID) export(mclapply, parallel, collect, mcparallel, pvec) S3method(print, process) useDynLib(multicore) multicore/DESCRIPTION0000644000175100001440000000140411632040137013775 0ustar hornikusersPackage: multicore Version: 0.1-7 Title: Parallel processing of R code on machines with multiple cores or CPUs Author: Simon Urbanek Maintainer: Simon Urbanek Depends: R (>= 2.0.0) Description: This package provides a way of running parallel computations in R on machines with multiple cores or CPUs. Jobs can share the entire initial workspace and it provides methods for results collection. License: GPL-2 SystemRequirements: POSIX-compliant OS (essentially anything but Windows; some Windows variants are supported experimentally, your mileage may vary) OS_type: unix URL: http://www.rforge.net/multicore/ Repository: CRAN Date/Publication: 2011-09-08 04:11:11 multicore/src/0000755000175100001440000000000011632020422013052 5ustar hornikusersmulticore/src/forknt.c0000644000175100001440000002311111632020422014517 0ustar hornikusers/* Implementation of COW fork() using NTDLL API for Windows systems (C)Copyright 2009 Simon Urbanek This code is partially based on the book "Windows NT/2000 Native API Reference" by Gary Nebbett (Sams Publishing, 2000, ISBN 1-57870-199-6) */ #ifdef WIN32 #include #include /* winternl.h is not part of MinGW so we have to declare whatever is needed */ #pragma mark ntdll API types typedef LONG NTSTATUS; typedef struct _SYSTEM_HANDLE_INFORMATION { ULONG ProcessId; UCHAR ObjectTypeNumber; UCHAR Flags; USHORT Handle; PVOID Object; ACCESS_MASK GrantedAccess; } SYSTEM_HANDLE_INFORMATION, *PSYSTEM_HANDLE_INFORMATION; typedef struct _OBJECT_ATTRIBUTES { ULONG Length; HANDLE RootDirectory; PVOID /* really PUNICODE_STRING */ ObjectName; ULONG Attributes; PVOID SecurityDescriptor; /* type SECURITY_DESCRIPTOR */ PVOID SecurityQualityOfService; /* type SECURITY_QUALITY_OF_SERVICE */ } OBJECT_ATTRIBUTES, *POBJECT_ATTRIBUTES; typedef enum _MEMORY_INFORMATION_{ MemoryBasicInformation, MemoryWorkingSetList, MemorySectionName, MemoryBasicVlmInformation } MEMORY_INFORMATION_CLASS; typedef struct _CLIENT_ID { HANDLE UniqueProcess; HANDLE UniqueThread; } CLIENT_ID, *PCLIENT_ID; typedef struct _USER_STACK { PVOID FixedStackBase; PVOID FixedStackLimit; PVOID ExpandableStackBase; PVOID ExpandableStackLimit; PVOID ExpandableStackBottom; } USER_STACK, *PUSER_STACK; typedef LONG KPRIORITY; typedef ULONG_PTR KAFFINITY; typedef KAFFINITY *PKAFFINITY; typedef struct _THREAD_BASIC_INFORMATION { NTSTATUS ExitStatus; PVOID TebBaseAddress; CLIENT_ID ClientId; KAFFINITY AffinityMask; KPRIORITY Priority; KPRIORITY BasePriority; } THREAD_BASIC_INFORMATION, *PTHREAD_BASIC_INFORMATION; typedef enum _THREAD_INFORMATION_CLASS { ThreadBasicInformation, ThreadTimes, ThreadPriority, ThreadBasePriority, ThreadAffinityMask, ThreadImpersonationToken, ThreadDescriptorTableEntry, ThreadEnableAlignmentFaultFixup, ThreadEventPair, ThreadQuerySetWin32StartAddress, ThreadZeroTlsCell, ThreadPerformanceCount, ThreadAmILastThread, ThreadIdealProcessor, ThreadPriorityBoost, ThreadSetTlsArrayAddress, ThreadIsIoPending, ThreadHideFromDebugger } THREAD_INFORMATION_CLASS, *PTHREAD_INFORMATION_CLASS; typedef enum _SYSTEM_INFORMATION_CLASS { SystemHandleInformation = 0x10 } SYSTEM_INFORMATION_CLASS; #pragma mark ntdll API - function entry points typedef NTSTATUS (NTAPI *ZwWriteVirtualMemory_t)(IN HANDLE ProcessHandle, IN PVOID BaseAddress, IN PVOID Buffer, IN ULONG NumberOfBytesToWrite, OUT PULONG NumberOfBytesWritten OPTIONAL); typedef NTSTATUS (NTAPI *ZwCreateProcess_t)(OUT PHANDLE ProcessHandle, IN ACCESS_MASK DesiredAccess, IN POBJECT_ATTRIBUTES ObjectAttributes, IN HANDLE InheriteFromProcessHandle, IN BOOLEAN InheritHandles, IN HANDLE SectionHandle OPTIONAL, IN HANDLE DebugPort OPTIONAL, IN HANDLE ExceptionPort OPTIONAL); typedef NTSTATUS (WINAPI *ZwQuerySystemInformation_t)(SYSTEM_INFORMATION_CLASS SystemInformationClass, PVOID SystemInformation, ULONG SystemInformationLength, PULONG ReturnLength); typedef NTSTATUS (NTAPI *ZwQueryVirtualMemory_t)(IN HANDLE ProcessHandle, IN PVOID BaseAddress, IN MEMORY_INFORMATION_CLASS MemoryInformationClass, OUT PVOID MemoryInformation, IN ULONG MemoryInformationLength, OUT PULONG ReturnLength OPTIONAL); typedef NTSTATUS (NTAPI *ZwGetContextThread_t)(IN HANDLE ThreadHandle, OUT PCONTEXT Context); typedef NTSTATUS (NTAPI *ZwCreateThread_t)(OUT PHANDLE ThreadHandle, IN ACCESS_MASK DesiredAccess, IN POBJECT_ATTRIBUTES ObjectAttributes, IN HANDLE ProcessHandle, OUT PCLIENT_ID ClientId, IN PCONTEXT ThreadContext, IN PUSER_STACK UserStack, IN BOOLEAN CreateSuspended); typedef NTSTATUS (NTAPI *ZwResumeThread_t)(IN HANDLE ThreadHandle, OUT PULONG SuspendCount OPTIONAL); typedef NTSTATUS (NTAPI *ZwClose_t)(IN HANDLE ObjectHandle); typedef NTSTATUS (NTAPI *ZwQueryInformationThread_t)(IN HANDLE ThreadHandle, IN THREAD_INFORMATION_CLASS ThreadInformationClass, OUT PVOID ThreadInformation, IN ULONG ThreadInformationLength, OUT PULONG ReturnLength OPTIONAL ); /* function pointers */ static ZwCreateProcess_t ZwCreateProcess; static ZwQuerySystemInformation_t ZwQuerySystemInformation; static ZwQueryVirtualMemory_t ZwQueryVirtualMemory; static ZwCreateThread_t ZwCreateThread; static ZwGetContextThread_t ZwGetContextThread; static ZwResumeThread_t ZwResumeThread; static ZwClose_t ZwClose; static ZwQueryInformationThread_t ZwQueryInformationThread; static ZwWriteVirtualMemory_t ZwWriteVirtualMemory; /* macro definitions */ #define NtCurrentProcess() ((HANDLE)-1) #define NtCurrentThread() ((HANDLE) -2) /* we use really the Nt versions - so the following is just for completeness */ #define ZwCurrentProcess() NtCurrentProcess() #define ZwCurrentThread() NtCurrentThread() #define STATUS_INFO_LENGTH_MISMATCH ((NTSTATUS)0xC0000004L) #define STATUS_SUCCESS ((NTSTATUS)0x00000000L) #pragma mark -- helper functions -- #ifdef INHERIT_ALL /* set all handles belonging to this process as inheritable */ static void set_inherit_all() { ULONG n = 0x1000; PULONG p = (PULONG) calloc(n, sizeof(ULONG)); /* some guesswork to allocate a structure that will fit it all */ while (ZwQuerySystemInformation(SystemHandleInformation, p, n * sizeof(ULONG), 0) == STATUS_INFO_LENGTH_MISMATCH) { free(p); n *= 2; p = (PULONG) calloc(n, sizeof(ULONG)); } /* p points to an ULONG with the count, the entries follow (hence p[0] is the size and p[1] is where the first entry starts */ PSYSTEM_HANDLE_INFORMATION h = (PSYSTEM_HANDLE_INFORMATION)(p + 1); ULONG pid = GetCurrentProcessId(); ULONG i = 0, count = *p; while (i < count) { if (h[i].ProcessId == pid) SetHandleInformation((HANDLE)(ULONG) h[i].Handle, HANDLE_FLAG_INHERIT, HANDLE_FLAG_INHERIT); i++; } free(p); } #endif /* setjmp env for the jump back into the fork() function */ static jmp_buf jenv; /* entry point for our child thread process - just longjmp into fork */ static int child_entry(void) { longjmp(jenv, 1); return 0; } /* initialize NTDLL entry points */ static int init_NTAPI(void) { HANDLE ntdll = GetModuleHandle("ntdll"); if (ntdll == NULL) return -1; ZwCreateProcess = (ZwCreateProcess_t) GetProcAddress(ntdll, "ZwCreateProcess"); ZwQuerySystemInformation = (ZwQuerySystemInformation_t) GetProcAddress(ntdll, "ZwQuerySystemInformation"); ZwQueryVirtualMemory = (ZwQueryVirtualMemory_t) GetProcAddress(ntdll, "ZwQueryVirtualMemory"); ZwCreateThread = (ZwCreateThread_t) GetProcAddress(ntdll, "ZwCreateThread"); ZwGetContextThread = (ZwGetContextThread_t) GetProcAddress(ntdll, "ZwGetContextThread"); ZwResumeThread = (ZwResumeThread_t) GetProcAddress(ntdll, "ZwResumeThread"); ZwQueryInformationThread = (ZwQueryInformationThread_t) GetProcAddress(ntdll, "ZwQueryInformationThread"); ZwWriteVirtualMemory = (ZwWriteVirtualMemory_t) GetProcAddress(ntdll, "ZwWriteVirtualMemory"); ZwClose = (ZwClose_t) GetProcAddress(ntdll, "ZwClose"); /* in theory we chould check all of them - but I guess that would be a waste of time ... */ return (!ZwCreateProcess) ? -1 : 0; } #pragma mark -- fork() -- int fork(void) { if (setjmp(jenv) != 0) return 0; /* return as a child */ /* check whether the entry points are initilized and get them if necessary */ if (!ZwCreateProcess && init_NTAPI()) return -1; #ifdef INHERIT_ALL /* make sure all handles are inheritable */ set_inherit_all(); #endif HANDLE hProcess = 0, hThread = 0; OBJECT_ATTRIBUTES oa = { sizeof(oa) }; /* create forked process */ ZwCreateProcess(&hProcess, PROCESS_ALL_ACCESS, &oa, NtCurrentProcess(), TRUE, 0, 0, 0); CONTEXT context = {CONTEXT_FULL | CONTEXT_DEBUG_REGISTERS | CONTEXT_FLOATING_POINT}; /* set the Eip for the child process to our child function */ ZwGetContextThread(NtCurrentThread(), &context); context.Eip = (ULONG)child_entry; MEMORY_BASIC_INFORMATION mbi; ZwQueryVirtualMemory(NtCurrentProcess(), (PVOID)context.Esp, MemoryBasicInformation, &mbi, sizeof mbi, 0); USER_STACK stack = {0, 0, (PCHAR)mbi.BaseAddress + mbi.RegionSize, mbi.BaseAddress, mbi.AllocationBase}; CLIENT_ID cid; /* create thread using the modified context and stack */ ZwCreateThread(&hThread, THREAD_ALL_ACCESS, &oa, hProcess, &cid, &context, &stack, TRUE); /* copy exception table */ THREAD_BASIC_INFORMATION tbi; ZwQueryInformationThread(NtCurrentThread(), ThreadBasicInformation, &tbi, sizeof tbi, 0); PNT_TIB tib = (PNT_TIB)tbi.TebBaseAddress; ZwQueryInformationThread(hThread, ThreadBasicInformation, &tbi, sizeof tbi, 0); ZwWriteVirtualMemory(hProcess, tbi.TebBaseAddress, &tib->ExceptionList, sizeof tib->ExceptionList, 0); /* start (resume really) the child */ ZwResumeThread(hThread, 0); /* clean up */ ZwClose(hThread); ZwClose(hProcess); /* exit with child's pid */ return (int)cid.UniqueProcess; } /* Dear Emacs, please be nice and use Local Variables: mode:c tab-width: 4 c-basic-offset:4 End: */ #else /* unix has fork() already */ #include #endif multicore/src/fork.c0000644000175100001440000004317311632020422014167 0ustar hornikusers/* multicore R package fork.c interface to system-level tools for sawning copies of the current process and IPC (C)Copyright 2008-11 Simon Urbanek see package DESCRIPTION for licensing terms */ #include #include #ifndef WIN32 /* --- plain unix parte --- */ #include #include #else /* --- work arounds for Windows --- */ #include #include "winfix.h" #define read _read #define write _write #define close _close #define select pipe_select #endif #include #include #include #include /* for AQUA */ #if HAVE_AQUA #include #endif #ifndef FILE_LOG /* use printf instead of Rprintf for debugging to avoid forked console interactions */ #define Dprintf printf #else /* logging into a file */ #include void Dprintf(char *format, ...) { va_list (args); va_start (args, format); FILE *f = fopen("mc_debug.txt", "a"); if (f) { fprintf(f, "%d> ", getpid()); vfprintf(f, format, args); fclose(f); } va_end (args); } #endif typedef struct child_info { pid_t pid; int pfd, sifd; #ifdef WIN32 HANDLE mutex; /* mutex for releasing a child */ #endif struct child_info *next; } child_info_t; static child_info_t *children; static int master_fd = -1; static int is_master = 1; static int rm_child_(int pid) { child_info_t *ci = children, *prev = 0; #ifdef MC_DEBUG Dprintf("removing child %d\n", pid); #endif while (ci) { if (ci->pid == pid) { #ifdef WIN32 HANDLE mutex = ci->mutex; #endif /* make sure we close all descriptors */ if (ci->pfd > 0) { close(ci->pfd); ci->pfd = -1; } if (ci->sifd > 0) { close(ci->sifd); ci->sifd = -1; } /* now remove it from the list */ if (prev) prev->next = ci->next; else children = ci->next; free(ci); #ifdef WIN32 ReleaseMutex(mutex); CloseHandle(mutex); /* just in case doesn't really work ... */ TerminateProcess((HANDLE) pid, 0); #else kill(pid, SIGUSR1); /* send USR1 to the child to make sure it exits */ #endif return 1; } prev = ci; ci = ci->next; } #ifdef MC_DEBUG Dprintf("WARNING: child %d was to be removed but it doesn't exist\n", pid); #endif return 0; } #ifndef STDIN_FILENO #define STDIN_FILENO 0 #endif #ifndef STDOUT_FILENO #define STDOUT_FILENO 1 #endif #ifndef STDERR_FILENO #define STDERR_FILENO 2 #endif static int child_can_exit = 0, child_exit_status = -1; #ifndef WIN32 static void child_sig_handler(int sig) { if (sig == SIGUSR1) { #ifdef MC_DEBUG Dprintf("child process %d got SIGUSR1; child_exit_status=%d\n", getpid(), child_exit_status); #endif child_can_exit = 1; if (child_exit_status >= 0) exit(child_exit_status); } } #else HANDLE child_release_mutex; #endif #if HAVE_AQUA /* from aqua.c */ extern void (*ptr_R_ProcessEvents)(void); static int find_quartz_symbols = 1; void (*QuartzCocoa_InhibitEventLoop)(int); typedef void (*QuartzCocoa_InhibitEventLoop_t)(int); /* unfortunately Rdynload.h forgets to declare it so the API is broken - we need to fix it */ struct Rf_RegisteredNativeSymbol { NativeSymbolType type; void *fn, *dll; }; /* check whether Quartz is loaded (if not, returns -1) and if so returns 1 is QuartzCocoa_InhibitEventLoop has been found 0 otherwise */ static int getQuartzSymbols() { if (find_quartz_symbols) { R_RegisteredNativeSymbol symbol = {R_ANY_SYM, NULL, NULL}; if (R_FindSymbol("getQuartzAPI", "", &symbol)) { /* is Quartz loaded? if not, we have nothing to worry about */ /* unfortunately R disables dynamic lookup in grDevices so we need to get at it manually this means that we need to get the corresponding DllInfo to enable it, then look up the symbol and disable it again */ SEXP getNativeSymbolInfo = install("getNativeSymbolInfo"); SEXP nsi = eval(lang2(getNativeSymbolInfo, mkString("getQuartzAPI")), R_GlobalEnv); /* get nsi[[3]][[2]] which should be the path (we verify every step) */ if (TYPEOF(nsi) == VECSXP && LENGTH(nsi) > 2) { SEXP pkg = VECTOR_ELT(nsi, 2); if (TYPEOF(pkg) == VECSXP && LENGTH(pkg) > 1) { SEXP dpath = VECTOR_ELT(pkg, 1); if (TYPEOF(dpath) == STRSXP && LENGTH(dpath) > 0) { /* this is technically unnecessary since nsi actually contains the EXTPTR holding the DllInfo, gut we'll play it safe here */ DllInfo *dll = R_getDllInfo(CHAR(STRING_ELT(dpath, 0))); if (dll) { struct Rf_RegisteredNativeSymbol { NativeSymbolType type; void *fn, *dll; } symbol = { R_ANY_SYM, NULL, NULL }; R_useDynamicSymbols(dll, TRUE); /* turn on dynamic symbols */ /* it would be faster to use R_dlsym since we already have DllInfo but that is hidden so let's waste more cycles.. */ QuartzCocoa_InhibitEventLoop = (QuartzCocoa_InhibitEventLoop_t) R_FindSymbol("QuartzCocoa_InhibitEventLoop", "grDevices", (R_RegisteredNativeSymbol*) &symbol); R_useDynamicSymbols(dll, FALSE); /* turn them off - we got what we want */ } } } } /* do not try again since we did all the work */ find_quartz_symbols = 0; } } return find_quartz_symbols ? -1 : ((QuartzCocoa_InhibitEventLoop) ? 1 : 0); } #else static int getQuartzSymbols() { return -1; } #endif SEXP mc_fork() { int pipefd[2]; int sipfd[2]; pid_t pid; SEXP res = allocVector(INTSXP, 3); int *res_i = INTEGER(res); if (pipe(pipefd)) error("Unable to create a pipe."); if (pipe(sipfd)) { close(pipefd[0]); close(pipefd[1]); error("Unable to create a pipe."); } #ifdef WIN32 { SECURITY_ATTRIBUTES sa = { sizeof(SECURITY_ATTRIBUTES), NULL, TRUE }; child_release_mutex = CreateMutex(&sa, TRUE, NULL); } #endif getQuartzSymbols(); /* initialize Quartz symbols if needed (noop on non-Aqua systems) */ pid = fork(); if (pid == -1) { perror("fork"); close(pipefd[0]); close(pipefd[1]); close(sipfd[0]); close(sipfd[1]); #ifdef WIN32 CloseHandle(child_release_mutex); #endif error("Unable to fork."); } res_i[0] = (int) pid; if (pid == 0) { /* child */ close(pipefd[0]); /* close read end */ master_fd = res_i[1] = pipefd[1]; is_master = 0; #if HAVE_AQUA ptr_R_ProcessEvents = NULL; /* disable ProcessEvent since we can't call CF from now on */ #endif /* re-map stdin */ dup2(sipfd[0], STDIN_FILENO); close(sipfd[0]); /* master uses USR1 to signal that the child process can terminate */ child_exit_status = -1; child_can_exit = 0; #ifndef WIN32 signal(SIGUSR1, child_sig_handler); #endif #if HAVE_AQUA /* Quartz runs the event loop so we need to stop it if we can */ if (QuartzCocoa_InhibitEventLoop) QuartzCocoa_InhibitEventLoop(1); #endif #ifdef MC_DEBUG Dprintf("child process %d started\n", getpid()); #endif } else { /* master process */ child_info_t *ci; close(pipefd[1]); /* close write end of the data pipe */ close(sipfd[0]); /* close read end of the child-stdin pipe */ res_i[1] = pipefd[0]; res_i[2] = sipfd[1]; #ifdef MC_DEBUG Dprintf("parent registers new child %d\n", pid); #endif /* register the new child and its pipes */ ci = (child_info_t*) malloc(sizeof(child_info_t)); if (!ci) error("Memory allocation error."); ci->pid = pid; ci->pfd = pipefd[0]; ci->sifd= sipfd[1]; #ifdef WIN32 ci->mutex = child_release_mutex; /* since we're now forked, the pipes (and mutex) should not be inherited by other children (note that this may mess up FD handling but children should not use those anyway) */ SetHandleInformation((HANDLE)_get_osfhandle(ci->pfd), HANDLE_FLAG_INHERIT, 0); SetHandleInformation((HANDLE)_get_osfhandle(ci->sifd), HANDLE_FLAG_INHERIT, 0); SetHandleInformation(child_release_mutex, HANDLE_FLAG_INHERIT, 0); #if 0 /* also Windows doesn't support concurrent stdout/err, so we can close them */ close(STDOUT_FILENO); close(STDERR_FILENO); /* ok, the next one is insane - we abuse R_SetWin32 to clear out (possibly suicidal) callbacks */ structRstart s; s.rhome = R_Home; s.home = getenv("HOME"); s.CharacterMode = RTerm; s.ReadConsole s.WriteConsole s.WriteConsoleEx s.CallBack s.ShowMessage s.YesNoCancel s.Busy s.NoRenviron = 1; R_SetWin32(&s); #endif #endif ci->next = children; children = ci; } return res; } SEXP close_stdout() { close(STDOUT_FILENO); return R_NilValue; } SEXP close_stderr() { close(STDERR_FILENO); return R_NilValue; } SEXP close_fds(SEXP sFDS) { int *fd, fds, i = 0; if (TYPEOF(sFDS) != INTSXP) error("descriptors must be integers"); fds = LENGTH(sFDS); fd = INTEGER(sFDS); while (i < fds) close(fd[i++]); return ScalarLogical(1); } SEXP send_master(SEXP what) { unsigned char *b; unsigned int len = 0, i = 0; if (is_master) error("only children can send data to the master process"); if (master_fd == -1) error("there is no pipe to the master process"); if (TYPEOF(what) != RAWSXP) error("content to send must be RAW, use serialize if needed"); len = LENGTH(what); b = RAW(what); #ifdef MC_DEBUG Dprintf("child %d: send_master (%d bytes)\n", getpid(), len); #endif if (write(master_fd, &len, sizeof(len)) != sizeof(len)) { close(master_fd); master_fd = -1; error("write error, closing pipe to the master"); } while (i < len) { int n = write(master_fd, b + i, len - i); if (n < 1) { close(master_fd); master_fd = -1; error("write error, closing pipe to the master"); } i += n; } return ScalarLogical(1); } SEXP send_child_stdin(SEXP sPid, SEXP what) { unsigned char *b; unsigned int len = 0, i = 0, fd; int pid = asInteger(sPid); if (!is_master) error("only master (parent) process can send data to a child process"); if (TYPEOF(what) != RAWSXP) error("what must be a raw vector"); child_info_t *ci = children; while (ci) { if (ci->pid == pid) break; ci = ci -> next; } if (!ci) error("child %d doesn't exist", pid); len = LENGTH(what); b = RAW(what); fd = ci -> sifd; while (i < len) { int n = write(fd, b + i, len - i); if (n < 1) error("write error"); i += n; } return ScalarLogical(1); } SEXP select_children(SEXP sTimeout, SEXP sWhich) { int maxfd = 0, sr, zombies = 0; unsigned int wlen = 0, wcount = 0; SEXP res; int *res_i, *which = 0; child_info_t *ci = children; fd_set fs; struct timeval tv = { 0, 0 }, *tvp = &tv; if (isReal(sTimeout) && LENGTH(sTimeout) == 1) { double tov = asReal(sTimeout); if (tov < 0.0) tvp = 0; /* Note: I'm not sure we really should allow this .. */ else { tv.tv_sec = (int) tov; tv.tv_usec = (int) ((tov - ((double) tv.tv_sec)) * 1000000.0); } } if (TYPEOF(sWhich) == INTSXP && LENGTH(sWhich)) { which = INTEGER(sWhich); wlen = LENGTH(sWhich); } #ifndef WIN32 { int wstat; while (waitpid(-1, &wstat, WNOHANG) > 0) {}; } /* check for zombies */ #endif FD_ZERO(&fs); while (ci && ci->pid) { if (ci->pfd == -1) zombies++; if (ci->pfd > maxfd) maxfd = ci->pfd; if (ci->pfd > 0) { if (which) { /* check for the FD only if it's on the list */ unsigned int k = 0; while (k < wlen) if (which[k++] == ci->pid) { FD_SET(ci->pfd, &fs); wcount++; break; } } else FD_SET(ci->pfd, &fs); } ci = ci -> next; } #ifdef MC_DEBUG Dprintf("select_children: maxfd=%d, wlen=%d, wcount=%d, zombies=%d, timeout=%d:%d\n", maxfd, wlen, wcount, zombies, (int)tv.tv_sec, (int)tv.tv_usec); #endif if (zombies) { /* oops, this should never really hapen - it did while we had a bug in rm_child_ but hopefully not anymore */ while (zombies) { /* this is rather more complicated than it should be if we used pointers to delete, but well ... */ ci = children; while (ci) { if (ci->pfd == -1) { #ifdef MC_DEBUG Dprintf("detected zombie: pid=%d, pfd=%d, sifd=%d\n", ci->pid, ci->pfd, ci->sifd); #endif rm_child_(ci->pid); zombies--; break; } ci = ci->next; } if (!ci) break; } } if (maxfd == 0 || (wlen && !wcount)) return R_NilValue; /* NULL signifies no children to tend to */ sr = select(maxfd + 1, &fs, 0, 0, tvp); #ifdef MC_DEBUG Dprintf(" sr = %d\n", sr); #endif if (sr < 0) { perror("select"); return ScalarLogical(0); /* FALSE on select error */ } if (sr < 1) return ScalarLogical(1); /* TRUE on timeout */ ci = children; maxfd = 0; while (ci && ci->pid) { /* pass 1 - count the FDs (in theory not necessary since that's what select should have returned) */ if (ci->pfd > 0 && FD_ISSET(ci->pfd, &fs)) maxfd++; ci = ci -> next; } ci = children; #ifdef MC_DEBUG Dprintf(" - read select %d children: ", maxfd); #endif res = allocVector(INTSXP, maxfd); res_i = INTEGER(res); while (ci && ci->pid) { /* pass 2 - fill the array */ if (ci->pfd > 0 && FD_ISSET(ci->pfd, &fs)) (res_i++)[0] = ci->pid; #ifdef MC_DEBUG if (ci->pfd > 0 && FD_ISSET(ci->pfd, &fs)) Dprintf("%d ", ci->pid); #endif ci = ci -> next; } #ifdef MC_DEBUG Dprintf("\n"); #endif return res; } static SEXP read_child_ci(child_info_t *ci) { unsigned int len = 0; int fd = ci->pfd; int n = read(fd, &len, sizeof(len)); #ifdef MC_DEBUG Dprintf(" read_child_ci(%d) - read length returned %d\n", ci->pid, n); #endif if (n != sizeof(len) || len == 0) { /* error or child is exiting */ int pid = ci->pid; close(fd); ci->pfd = -1; rm_child_(pid); return ScalarInteger(pid); } else { SEXP rv = allocVector(RAWSXP, len); unsigned char *rvb = RAW(rv); unsigned int i = 0; while (i < len) { n = read(fd, rvb + i, len - i); #ifdef MC_DEBUG Dprintf(" read_child_ci(%d) - read %d at %d returned %d\n", ci->pid, len-i, i, n); #endif if (n < 1) { int pid = ci->pid; close(fd); ci->pfd = -1; rm_child_(pid); return ScalarInteger(pid); } i += n; } PROTECT(rv); { SEXP pa = allocVector(INTSXP, 1); INTEGER(pa)[0] = ci->pid; setAttrib(rv, install("pid"), pa); } UNPROTECT(1); return rv; } } SEXP read_child(SEXP sPid) { int pid = asInteger(sPid); child_info_t *ci = children; while (ci) { if (ci->pid == pid) break; ci = ci->next; } #ifdef MC_DEBUG if (!ci) Dprintf("read_child(%d) - pid is not in the list of children\n", pid); #endif if (!ci) return R_NilValue; /* if the child doesn't exist anymore, returns NULL */ return read_child_ci(ci); } SEXP read_children(SEXP sTimeout) { int maxfd = 0, sr; child_info_t *ci = children; fd_set fs; struct timeval tv = { 0, 0 }, *tvp = &tv; if (isReal(sTimeout) && LENGTH(sTimeout) == 1) { double tov = asReal(sTimeout); if (tov < 0.0) tvp = 0; /* Note: I'm not sure we really should allow this .. */ else { tv.tv_sec = (int) tov; tv.tv_usec = (int) ((tov - ((double) tv.tv_sec)) * 1000000.0); } } #ifndef WIN32 { int wstat; while (waitpid(-1, &wstat, WNOHANG) > 0) {}; } /* check for zombies */ #endif FD_ZERO(&fs); while (ci && ci->pid) { if (ci->pfd > maxfd) maxfd = ci->pfd; if (ci->pfd > 0) FD_SET(ci->pfd, &fs); ci = ci -> next; } #ifdef MC_DEBUG Dprintf("read_children: maxfd=%d, timeout=%d:%d\n", maxfd, (int)tv.tv_sec, (int)tv.tv_usec); #endif if (maxfd == 0) return R_NilValue; /* NULL signifies no children to tend to */ sr = select(maxfd+1, &fs, 0, 0, tvp); #ifdef MC_DEBUG Dprintf("sr = %d\n", sr); #endif if (sr < 0) { perror("select"); return ScalarLogical(0); /* FALSE on select error */ } if (sr < 1) return ScalarLogical(1); /* TRUE on timeout */ ci = children; while (ci && ci->pid) { if (ci->pfd > 0 && FD_ISSET(ci->pfd, &fs)) break; ci = ci -> next; } #ifdef MC_DEBUG Dprintf("set ci=%p (%d, %d)\n", (void*) ci, ci?ci->pid:0, ci?ci->pfd:0); #endif /* this should never occur really - select signalled a read handle but none of the handles is set - let's treat it as a timeout */ if (!ci) return ScalarLogical(1); else return read_child_ci(ci); /* we should never land here */ return R_NilValue; } SEXP rm_child(SEXP sPid) { int pid = asInteger(sPid); return ScalarLogical(rm_child_(pid)); } SEXP mc_children() { unsigned int count = 0; SEXP res; int *pids; child_info_t *ci = children; while (ci && ci->pid > 0) { count++; ci = ci->next; } res = allocVector(INTSXP, count); if (count) { pids = INTEGER(res); ci = children; while (ci && ci->pid > 0) { (pids++)[0] = ci->pid; ci = ci->next; } } return res; } SEXP mc_fds(SEXP sFdi) { int fdi = asInteger(sFdi); unsigned int count = 0; SEXP res; child_info_t *ci = children; while (ci && ci->pid > 0) { count++; ci = ci->next; } res = allocVector(INTSXP, count); if (count) { int *fds = INTEGER(res); ci = children; while (ci && ci->pid > 0) { (fds++)[0] = (fdi == 0) ? ci->pfd : ci->sifd; ci = ci->next; } } return res; } SEXP mc_master_fd() { return ScalarInteger(master_fd); } SEXP mc_is_child() { return ScalarLogical(is_master?0:1); } SEXP mc_kill(SEXP sPid, SEXP sSig) { #ifdef WIN32 error("signals are not supported on Windows"); return R_NilValue; #else int pid = asInteger(sPid); int sig = asInteger(sSig); if (kill((pid_t) pid, sig)) error("Kill failed."); return ScalarLogical(1); #endif } SEXP mc_exit(SEXP sRes) { int res = asInteger(sRes); #ifdef MC_DEBUG Dprintf("child %d: exit called\n", getpid()); #endif if (is_master) error("exit can only be used in a child process"); if (master_fd != -1) { /* send 0 to signify that we're leaving */ unsigned int len = 0; write(master_fd, &len, sizeof(len)); /* make sure the pipe is closed before we enter any waiting */ close(master_fd); master_fd = -1; } #ifdef WIN32 /* master locks the mutex until it's ready to collect the result */ WaitForSingleObject(child_release_mutex, INFINITE); #else if (!child_can_exit) { #ifdef MC_DEBUG Dprintf("child %d is waiting for permission to exit\n", getpid()); #endif while (!child_can_exit) { sleep(1); } } #endif #ifdef MC_DEBUG Dprintf("child %d: exiting\n", getpid()); #endif exit(res); error("exit failed"); return R_NilValue; } /* this is not really necessary, since from R you can simply use is.loaded("QuartzCocoa_InhibitEventLoop") and it will be TRUE if we got to it. */ SEXP mc_can_disable_quartz() { return Rf_ScalarLogical(getQuartzSymbols()); } multicore/src/perf.c0000644000175100001440000000034511632020422014154 0ustar hornikusers/* performance-enhancing functions */ #define USE_RINTERNALS 1 #include SEXP create_list(SEXP sLength) { int len = Rf_asInteger(sLength); if (len < 1) len = 0; return Rf_allocVector(VECSXP, len); } multicore/src/winfix.c0000644000175100001440000000253111632020422014523 0ustar hornikusers/* work-arounds and fixes for Windows */ #ifdef WIN32 #include #include "winfix.h" /* Wait for any of the descriptors to become signalled. The implementation uses WaitForMultipleObjects which can only signal one object at a time, so in fact the result will be -1, 0 or 1. Also note that we are using readfds *only*, all others are ignored. */ int pipe_select(int nfds, fd_set *readfds, fd_set *writefds, fd_set *errorfds, struct timeval *timeout) { HANDLE h[MAXIMUM_WAIT_OBJECTS]; int fd[MAXIMUM_WAIT_OBJECTS]; DWORD n, hs = 0, tout = INFINITE; int i = 0, sii = -1; while (i < nfds) { if (FD_ISSET(i, readfds)) { h[hs] = (HANDLE) _get_osfhandle(i); fd[hs++] = i; if (hs >= MAXIMUM_WAIT_OBJECTS) break; } i++; } if (hs < 1) return -1; if (timeout) tout = (timeout->tv_sec * 1000) + (timeout->tv_usec / 1000); n = WaitForMultipleObjects(hs, h, FALSE, tout); if (n >= WAIT_OBJECT_0 && n - WAIT_OBJECT_0 < hs) sii = (int) (n - WAIT_OBJECT_0); else if (n >= WAIT_ABANDONED_0 && n - WAIT_ABANDONED_0 < hs) sii = (int) (n - WAIT_ABANDONED_0); if (n == WAIT_FAILED) return -1; if (sii == -1) return 0; else { FD_ZERO(readfds); FD_SET(fd[n - WAIT_OBJECT_0], readfds); } return 1; } #else /* this is only a dummy to avoid warning by various compilers about empty files, superfluous semicolons etc. */ typedef int foo_t; #endif multicore/src/winfix.h0000644000175100001440000000071511632020422014532 0ustar hornikusers#include #include /* for _O_BINARY */ /* our implementation from windows/forknt.c */ extern int fork(); /* our own implementation of select using WaitForMultipleObjects */ int pipe_select(int xfd, fd_set *sr, fd_set *sw, fd_set *se, struct timeval *timeout); #define sleep(X) Sleep((X) * 1000) #define pipe(fds) _pipe(fds, 4096, _O_BINARY) /* Windows includes re-define ERROR which is used by R .. */ #ifdef ERROR #undef ERROR #endif multicore/src/Makevars.win0000644000175100001440000000002311632020422015335 0ustar hornikusersPKG_LIBS=-lwsock32 multicore/MD50000644000175100001440000000214011632040137012575 0ustar hornikusers8a5bb2273d6610652b9ec3c5ec0a65c6 *DESCRIPTION 062b4319652c953308e5557b551d0a04 *NAMESPACE 5ace0e9b2b4b1cb54b0ea329b5ffe4e1 *NEWS db201bd4f13c7ca369fb105e515b1ec5 *R/fork.R e1106d81c77dbed838844157035a7c9a *R/mclapply.R 752a8d97c266a72ca9d3f13e8a8b7e64 *R/parallel.R df61185cd5bff484ce25fdceb4b261d5 *R/print.R 52f28f21f4a0734840780ea98fea97b5 *R/pvec.R 7027660308ddbdb17f2a4d72e8b43464 *R/zzz.R e525b9e60989eabbc3c816461651ac48 *man/children.Rd a5bbdeb96be4c98320cc67ec227c69f3 *man/fork.Rd d97ed592a2d3a4bc5db5817d737d0848 *man/mclapply.Rd 17ffb7dca1bad364d1959adda73ccd5f *man/multicore.Rd 62bac5b35ab94deb2b62c505ee932bf7 *man/parallel.Rd 0319df886a2a7a74d76bb5d34ebcf610 *man/process.Rd afc3ce0d941fd86261ff19f27c5deabc *man/pvec.Rd 5cd47bb2fa413f0410a220833ec6a737 *man/sendMaster.Rd 35fab0e5ff984b7ec511c67dccf3b88e *man/signals.Rd 929e9090521f8c895a2bde7dbd1c4889 *src/Makevars.win 380dfe7b5b024a970d9faab673a3ae3f *src/fork.c fd19daceed1512fcaf95843968cd555c *src/forknt.c 5c4765cd647a166397a6e2991bef0773 *src/perf.c 4809c18e318e3d0703b3213507a68783 *src/winfix.c 9c27c366ddd6854b5a9b6894566cd3f2 *src/winfix.h