@@@ more wip

[runlisp] / dump-runlisp-image.c

/* -*-c-*-
 *
 * Dump custom Lisp images for faster script execution
 *
 * (c) 2020 Mark Wooding
 */

/*----- Licensing notice --------------------------------------------------*
 *
 * This file is part of Runlisp, a tool for invoking Common Lisp scripts.
 *
 * Runlisp is free software: you can redistribute it and/or modify it
 * under the terms of the GNU General Public License as published by the
 * Free Software Foundation; either version 3 of the License, or (at your
 * option) any later version.
 *
 * Runlisp is distributed in the hope that it will be useful, but WITHOUT
 * ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
 * FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
 * for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with Runlisp.  If not, see <https://www.gnu.org/licenses/>.
 */

/*----- Header files ------------------------------------------------------*/

#include "config.h"

#include <assert.h>
#include <ctype.h>
#include <errno.h>
#include <signal.h>
#include <stdio.h>
#include <stdlib.h>
#include <string.h>
#include <time.h>

#include <dirent.h>
#include <fcntl.h>
#include <unistd.h>

#include <sys/select.h>
#include <sys/stat.h>
#include <sys/time.h>
#include <sys/uio.h>
#include <sys/wait.h>

#include "common.h"
#include "lib.h"
#include "mdwopt.h"

/*----- Static data -------------------------------------------------------*/

/* The state required to break an output stream from a subprocess into lines
 * so we can prefix them appropriately.  Once our process starts, the `buf'
 * points to a buffer of `MAXLINE' bytes.  This is arranged as a circular
 * buffer, containing `len' bytes starting at offset `off', and wrapping
 * around to the start of the buffer if it runs off the end.
 *
 * The descriptor `fd' is reset to -1 after it's seen end-of-file.
 */
struct linebuf {
  int fd;                               /* our file descriptor (or -1) */
  char *buf;                            /* line buffer, or null */
  unsigned off, len;                    /* offset */
};
#define MAXLINE 16384u                  /* maximum acceptable line length */

/* Job-state constants. */
enum {
  JST_READY,                            /* not yet started */
  JST_RUN,                              /* currently running */
  JST_DEAD,                             /* process exited */
  JST_NSTATE
};

/* The state associated with an image-dumping job. */
struct job {
  struct treap_node _node;              /* treap intrusion */
  struct job *next;                     /* next job in whichever list */
  struct argv av;                       /* argument vector to execute */
  char *imgnew, *imgout;                /* staging and final output files */
  unsigned st;                          /* job state (`JST_...') */
  FILE *log;                            /* log output file (`stdout'?) */
  pid_t kid;                            /* process id of child (or -1) */
  int exit;                             /* exit status from child */
  struct linebuf out, err;              /* line buffers for stdout, stderr */
};
#define JOB_NAME(job) TREAP_NODE_KEY(job)
#define JOB_NAMELEN(job) TREAP_NODE_KEYLEN(job)

static struct treap jobs = TREAP_INIT;  /* Lisp systems scheduled to dump */
static struct job *job_ready, *job_run, *job_dead; /* list jobs by state */
static unsigned nrun, maxrun = 1;       /* running and maximum job counts */
static int rc = 0;                      /* code that we should return */
static int nullfd;                      /* file descriptor for `/dev/null' */
static const char *tmpdir;              /* temporary directory path */

static int sig_pipe[2] = { -1, -1 };    /* pipe for reporting signals */
static sigset_t caught, pending;        /* signals we catch; have caught */
static int sigloss = -1;                /* signal that caused us to lose */

static unsigned flags = 0;              /* flags for the application */
#define AF_BOGUS 0x0001u                /*   invalid comand-line syntax */
#define AF_SETCONF 0x0002u              /*   explicit configuration */
#define AF_DRYRUN 0x0004u               /*   don't actually do it */
#define AF_ALL 0x0008u                  /*   dump all known Lisps */
#define AF_FORCE 0x0010u                /*   dump even if images exist */
#define AF_CHECKINST 0x0020u            /*   check Lisp exists before dump */

/*----- Miscellany --------------------------------------------------------*/

/* Report a (printf(3)-style) message MSG, and remember to fail later. */
static PRINTF_LIKE(1, 2) void bad(const char *msg, ...)
  { va_list ap; va_start(ap, msg); vmoan(msg, ap); va_end(ap); rc = 127; }

/*----- File utilities ----------------------------------------------------*/

/* Main recursive subroutine for `recursive_delete'.
 *
 * The string DD currently contains the pathname of a directory, without a
 * trailing `/' (though there is /space/ for a terminating zero or whatever).
 * Recursively delete all of the files and directories within it.  Appending
 * further text to DD is OK, but clobbering the characters which are there
 * already isn't allowed.
 */
static void recursive_delete_(struct dstr *dd)
{
  DIR *dir;
  struct dirent *d;
  size_t n = dd->len;

  /* Open the directory. */
  dd->p[n] = 0; dir = opendir(dd->p);
  if (!dir)
    lose("failed to open directory `%s' for cleanup: %s",
         dd->p, strerror(errno));

  /* We'll need to build pathnames for the files inside the directory, so add
   * the separating `/' character.  Remember the length of this prefix
   * because this is the point we'll be rewinding to for each filename we
   * find.
   */
  dd->p[n++] = '/';

  /* Now go through each file in turn. */
  for (;;) {

    /* Get a filename.  If we've run out then we're done.  Skip the special
     * `.' and `..' entries.
     */
    d = readdir(dir); if (!d) break;
    if (d->d_name[0] == '.' && (!d->d_name[1] ||
                                (d->d_name[1] == '.' && !d->d_name[2])))
      continue;

    /* Rewind the string offset and append the new filename. */
    dd->len = n; dstr_puts(dd, d->d_name);

    /* Try to delete it the usual way.  If it was actually a directory then
     * recursively delete it instead.  (We could lstat(2) it first, but this
     * should be at least as quick to identify a directory, and it'll save a
     * lstat(2) call in the (common) case that it's not a directory.
     */
    if (!unlink(dd->p));
    else if (errno == EISDIR) recursive_delete_(dd);
    else lose("failed to delete file `%s': %s", dd->p, strerror(errno));
  }

  /* We're done.  Try to delete the directory.  (It's possible that there was
   * some problem with enumerating the directory, but we'll ignore that: if
   * it matters then the directory won't be empty and the rmdir(2) will
   * fail.)
   */
  closedir(dir);
  dd->p[--n] = 0;
  if (rmdir(dd->p))
    lose("failed to delete directory `%s': %s", dd->p, strerror(errno));
}

/* Recursively delete the thing named PATH. */
static void recursive_delete(const char *path)
{
  struct dstr d = DSTR_INIT;
  dstr_puts(&d, path); recursive_delete_(&d); dstr_release(&d);
}

/* Configure a file descriptor FD.
 *
 * Set its nonblocking state to NONBLOCK and close-on-exec state to CLOEXEC.
 * In both cases, -1 means to leave it alone, zero means to turn it off, and
 * any other nonzero value means to turn it on.
 */
static int configure_fd(const char *what, int fd, int nonblock, int cloexec)
{
  int fl, nfl;

  if (nonblock != -1) {
    fl = fcntl(fd, F_GETFL); if (fl < 0) goto fail;
    if (nonblock) nfl = fl | O_NONBLOCK;
    else nfl = fl&~O_NONBLOCK;
    if (fl != nfl && fcntl(fd, F_SETFL, nfl)) goto fail;
  }

  if (cloexec != -1) {
    fl = fcntl(fd, F_GETFD); if (fl < 0) goto fail;
    if (cloexec) nfl = fl | FD_CLOEXEC;
    else nfl = fl&~FD_CLOEXEC;
    if (fl != nfl && fcntl(fd, F_SETFD, nfl)) goto fail;
  }

  return (0);

fail:
  bad("failed to configure %s descriptor: %s", what, strerror(errno));
  return (-1);
}

/* Create a temporary directory and remember where we put it. */
static void set_tmpdir(void)
{
  struct dstr d = DSTR_INIT;
  size_t n;
  unsigned i;

  /* Start building the path name.  Remember the length: we'll rewind to
   * here and try again if our first attempt doesn't work.
   */
  dstr_putf(&d, "%s/runlisp.%d.", my_getenv("TMPDIR", "/tmp"), getpid());
  i = 0; n = d.len;

  /* Keep trying until it works. */
  for (;;) {

    /* Build a complete name. */
    d.len = n; dstr_putf(&d, "%d", rand());

    /* Try to create the directory.  If it worked, we're done.  If it failed
     * with `EEXIST' then we'll try again for a while, but give up it it
     * doesn't look like we're making any progress.  If it failed for some
     * other reason then there's probably not much hope so give up.
     */
    if (!mkdir(d.p, 0700)) break;
    else if (errno != EEXIST)
      lose("failed to create temporary directory `%s': %s",
           d.p, strerror(errno));
    else if (++i >= 32) {
      d.len = n; dstr_puts(&d, "???");
      lose("failed to create temporary directory `%s': too many attempts",
           d.p);
    }
  }

  /* Remember the directory name. */
  tmpdir = xstrndup(d.p, d.len); dstr_release(&d);
}

/*----- Signal handling ---------------------------------------------------*/

/* Forward reference into job management. */
static void reap_children(void);

/* Clean things up on exit.
 *
 * Currently this just means to delete the temporary directory if we've made
 * one.
 */
static void cleanup(void)
  { if (tmpdir) { recursive_delete(tmpdir); tmpdir = 0; } }

/* Check to see whether any signals have arrived, and do the sensible thing
 * with them.
 */
static void check_signals(void)
{
  sigset_t old, pend;
  char buf[32];
  ssize_t n;

  /* Ensure exclusive access to the signal-handling machinery, drain the
   * signal pipe, and take a copy of the set of caught signals.
   */
  sigprocmask(SIG_BLOCK, &caught, &old);
  pend = pending; sigemptyset(&pending);
  for (;;) {
    n = read(sig_pipe[0], buf, sizeof(buf));
    if (!n) lose("(internal) signal pipe closed!");
    if (n < 0) break;
  }
  if (errno != EAGAIN && errno != EWOULDBLOCK)
    lose("failed to read signal pipe: %s", strerror(errno));
  sigprocmask(SIG_SETMASK, &old, 0);

  /* Check for each signal of interest to us.
   *
   * Interrupty signals just set `sigloss' -- the `run_jobs' loop will know
   * to unravel everything if this happens.  If `SIGCHLD' happened, then
   * check on job process status.
   */
  if (sigismember(&pend, SIGINT)) sigloss = SIGINT;
  else if (sigismember(&pend, SIGHUP)) sigloss = SIGHUP;
  else if (sigismember(&pend, SIGTERM)) sigloss = SIGTERM;
  if (sigismember(&pend, SIGCHLD)) reap_children();
}

/* The actual signal handler.
 *
 * Set the appropriate signal bit in `pending', and a byte (of any value)
 * down the signal pipe to wake up the select(2) loop.
 */
static void handle_signal(int sig)
{
  sigset_t old;
  char x = '!';

  /* Ensure exclusive access while we fiddle with the `caught' set. */
  sigprocmask(SIG_BLOCK, &caught, &old);
  sigaddset(&pending, sig);
  sigprocmask(SIG_SETMASK, &old, 0);

  /* Wake up the select(2) loop.  If this fails, there's not a lot we can do
   * about it.
   */
  DISCARD(write(sig_pipe[1], &x, 1));
}

/* Install our signal handler to catch SIG.
 *
 * If `SIGF_IGNOK' is set in F then don't trap the signal if it's currently
 * ignored.  (This is used for signals like `SIGINT', which usually should
 * interrupt us; but if the caller wants us to ignore them, we should do as
 * it wants.)
 *
 * WHAT describes the signal, for use in diagnostic messages.
 */
#define SIGF_IGNOK 1u
static void set_signal_handler(const char *what, int sig, unsigned f)
{
  struct sigaction sa, sa_old;

  sigaddset(&caught, sig);

  if (f&SIGF_IGNOK) {
    if (sigaction(sig, 0, &sa_old)) goto fail;
    if (sa_old.sa_handler == SIG_IGN) return;
  }

  sa.sa_handler = handle_signal;
  sigemptyset(&sa.sa_mask);
  sa.sa_flags = SA_NOCLDSTOP;
  if (sigaction(sig, &sa, 0)) goto fail;

  return;

fail:
  lose("failed to set %s signal handler: %s", what, strerror(errno));
}

/*----- Line buffering ----------------------------------------------------*/

/* Find the next newline in the line buffer BUF.
 *
 * The search starts at `BUF->off', and potentially covers the entire buffer
 * contents.  Set *LINESZ_OUT to the length of the line, in bytes.  (Callers
 * must beware that the text of the line may wrap around the ends of the
 * buffer.)  Return zero if we found a newline, or nonzero if the search
 * failed.
 */
static int find_newline(struct linebuf *buf, size_t *linesz_out)
{
  char *nl;

  if (buf->off + buf->len <= MAXLINE) {
    /* The buffer contents is in one piece.  Just search it. */

    nl = memchr(buf->buf + buf->off, '\n', buf->len);
    if (nl) { *linesz_out = (nl - buf->buf) - buf->off; return (0); }

  } else {
    /* The buffer contents is in two pieces.  We must search both of them. */

    nl = memchr(buf->buf + buf->off, '\n', MAXLINE - buf->off);
    if (nl) { *linesz_out = (nl - buf->buf) - buf->off; return (0); }
    nl = memchr(buf->buf, '\n', buf->len - (MAXLINE - buf->off));
    if (nl)
      { *linesz_out = (nl - buf->buf) + (MAXLINE - buf->off); return (0); }
  }

  return (-1);
}

/* Write a completed line out to the JOB's log file.
 *
 * The line starts at BUF->off, and continues for N bytes, not including the
 * newline (which, in fact, might not exist at all).  Precede the actual text
 * of the line with the JOB's name, and the MARKER character, and follow it
 * with the TAIL text (which should include an actual newline character).
 */
static void write_line(struct job *job, struct linebuf *buf,
                       size_t n, char marker, const char *tail)
{
  fprintf(job->log, "%-13s %c ", JOB_NAME(job), marker);
  if (buf->off + n <= MAXLINE)
    fwrite(buf->buf + buf->off, 1, n, job->log);
  else {
    fwrite(buf->buf + buf->off, 1, MAXLINE - buf->off, job->log);
    fwrite(buf->buf, 1, n - (MAXLINE - buf->off), job->log);
  }
  fputs(tail, job->log);
}

/* Collect output lines from JOB's process and write them to the log.
 *
 * Read data from BUF's file descriptor.  Output complete (or overlong) lines
 * usng `write_line'.  On end-of-file, output any final incomplete line in
 * the same way, close the descriptor, and set it to -1.
 */
static void prefix_lines(struct job *job, struct linebuf *buf, char marker)
{
  struct iovec iov[2]; int niov;
  ssize_t n;
  size_t linesz;

  /* Read data into the buffer.  This fancy dance with readv(2) is probably
   * overkill.
   *
   * We can't have BUF->len = MAXLINE because we'd have flushed out a
   * maximum-length buffer as an incomplete line last time.
   */
  assert(buf->len < MAXLINE);
  if (!buf->off) {
    iov[0].iov_base = buf->buf + buf->len;
    iov[0].iov_len = MAXLINE - buf->len;
    niov = 1;
  } else if (buf->off + buf->len >= MAXLINE) {
    iov[0].iov_base = buf->buf + buf->off + buf->len - MAXLINE;
    iov[0].iov_len = MAXLINE - buf->len;
    niov = 1;
  } else {
    iov[0].iov_base = buf->buf + buf->off + buf->len;
    iov[0].iov_len = MAXLINE - (buf->off + buf->len);
    iov[1].iov_base = buf->buf;
    iov[1].iov_len = buf->off;
    niov = 1;
  }
  n = readv(buf->fd, iov, niov);

  if (n < 0) {
    /* If there's no data to read after all then just move on.  Otherwise we
     * have a problem.
     */
    if (errno == EAGAIN || errno == EWOULDBLOCK) return;
    lose("failed to read job `%s' output stream: %s",
         JOB_NAME(job), strerror(errno));
  }

  /* Include the new material in the buffer length, and write out any
   * complete lines we find.
   */
  buf->len += n;
  while (!find_newline(buf, &linesz)) {
    write_line(job, buf, linesz, marker, "\n");
    buf->len -= linesz + 1;
    buf->off += linesz + 1; if (buf->off >= MAXLINE) buf->off -= MAXLINE;
  }

  if (!buf->len)
    /* If there's nothing left then we might as well reset the buffer offset
     * to the start of the buffer.
     */
    buf->off = 0;
  else if (buf->len == MAXLINE) {
    /* We've filled the buffer with stuff that's not a whole line.  Flush it
     * out anyway.
     */
    write_line(job, buf, MAXLINE, marker, " [...]\n");
    buf->off = buf->len = 0;
  }

  if (!n) {
    /* We've hit end-of-file.  Close the stream, and write out any
     * unterminated partial line.
     */
    close(buf->fd); buf->fd = -1;
    if (buf->len)
      write_line(job, buf, buf->len, marker, " [missing final newline]\n");
  }
}

/*----- Job management ----------------------------------------------------*/

/* Add a new job to the `ready' queue.
 *
 * The job will be to dump the Lisp system with the given LEN-byte NAME.  On
 * entry, *TAIL_INOUT should point to the `next' link of the last node in the
 * list (or the list head pointer), and will be updated on exit.
 *
 * This function reports (fatal) errors for most kinds of problems.  If
 * `JF_QUIET' is set in F then silently ignore a well-described Lisp system
 * which nonetheless isn't suitable.  (This is specifically intended for the
 * case where we try to dump all known Lisp systems, but some don't have a
 * `dump-image' command.)
 */
#define JF_QUIET 1u
static void add_job(struct job ***tail_inout, unsigned f,
                    const char *name, size_t len)
{
  struct job *job;
  struct treap_path path;
  struct config_section *sect;
  struct config_var *dumpvar, *cmdvar, *imgvar;
  struct dstr d = DSTR_INIT;
  struct argv av = ARGV_INIT;
  char *imgnew = 0, *imgout = 0;
  size_t i;
  unsigned fef;

  /* Check to see whether this Lisp system is already queued up. */
  job = treap_probe(&jobs, name, len, &path);
  if (job) {
    if (verbose >= 2) {
      moan("ignoring duplicate Lisp `%s'", JOB_NAME(job));
      return;
    }
  }

  /* Find the configuration for this Lisp system and check that it can be
   * dumped.
   */
  sect = config_find_section_n(&config, 0, name, len);
  if (!sect) lose("unknown Lisp implementation `%.*s'", (int)len, name);
  name = CONFIG_SECTION_NAME(sect);
  dumpvar = config_find_var(&config, sect, 0, "dump-image");
  if (!dumpvar) {
    if (!(f&JF_QUIET))
      lose("don't know how to dump images for Lisp implementation `%s'",
           name);
    goto end;
  }

  /* Check that the other necessary variables are present. */
  imgvar = config_find_var(&config, sect, 0, "image-file");
  if (!imgvar) lose("variable `image-file' not defined for Lisp `%s'", name);
  cmdvar = config_find_var(&config, sect, 0, "command");
  if (!cmdvar) lose("variable `command' not defined for Lisp `%s'", name);

  /* Build the job's command line. */
  config_subst_split_var(&config, sect, dumpvar, &av);
  if (!av.n)
    lose("empty `dump-image' command for Lisp implementation `%s'", name);

  /* If we're supposed to check that the Lisp exists before proceeding then
   * do that.  There are /two/ commands to check: the basic Lisp command,
   * /and/ the command to actually do the dumping, which might not be the
   * same thing.  (Be careful not to check the same command twice, though,
   * because that would cause us to spam the user with redundant
   * diagnostics.)
   */
  if (flags&AF_CHECKINST) {
    dstr_reset(&d);
    fef = (verbose >= 2 ? FEF_VERBOSE : 0);
    config_subst_var(&config, sect, cmdvar, &d);
    if (!found_in_path_p(d.p, fef) ||
        (STRCMP(d.p, !=, av.v[0]) && !found_in_path_p(av.v[0], fef))) {
      if (verbose >= 2) moan("skipping Lisp implementation `%s'", name);
      goto end;
    }
  }

  /* Collect the output image file names. */
  imgnew =
    config_subst_string_alloc(&config, sect, "<internal>", "${@image-new}");
  imgout =
    config_subst_string_alloc(&config, sect, "<internal>", "${@image-out}");

  /* If we're supposed to check whether the image file exists, then we should
   * do that.
   */
  if (!(flags&AF_FORCE)) {
    if (!access(imgout, F_OK)) {
      if (verbose >= 2)
        moan("image `%s' already exists: skipping `%s'", d.p, name);
      goto end;
    }
  }

  /* All preflight checks complete.  Build the job and hook it onto the end
   * of the list.  (Steal the command-line vector so that we don't try to
   * free it during cleanup.)
   */
  job = xmalloc(sizeof(*job));
  job->st = JST_READY;
  job->kid = -1;
  job->out.fd = -1; job->out.buf = 0;
  job->err.fd = -1; job->err.buf = 0;
  job->av = av; argv_init(&av);
  job->imgnew = imgnew; job->imgout = imgout; imgnew = imgout = 0;
  treap_insert(&jobs, &path, &job->_node, name, len);
  **tail_inout = job; *tail_inout = &job->next;

end:
  /* All done.  Cleanup time. */
  for (i = 0; i < av.n; i++) free(av.v[i]);
  free(imgnew); free(imgout);
  dstr_release(&d); argv_release(&av);
}

/* Free the JOB and all the resources it holds.
 *
 * Close the pipes; kill the child process.  Everything must go.
 */
static void release_job(struct job *job)
{
  size_t i;

  if (job->kid > 0) kill(job->kid, SIGKILL); /* ?? */
  if (job->log && job->log != stdout) fclose(job->log);
  free(job->imgnew); free(job->imgout);
  for (i = 0; i < job->av.n; i++) free(job->av.v[i]);
  argv_release(&job->av);
  free(job->out.buf); if (job->out.fd >= 0) close(job->out.fd);
  free(job->err.buf); if (job->err.fd >= 0) close(job->err.fd);
  free(job);
}

/* Do all the necessary things when JOB finishes (successfully or not).
 *
 * Eventually the job is freed (using `release_job').
 */
static void finish_job(struct job *job)
{
  char buf[16483];
  size_t n;
  int ok = 0;

  /* Start a final line to the job log describing its eventual fate.
   *
   * This is where we actually pick apart the exit status.  Set `ok' if it
   * actually succeeded, because that's all anything else cares about.
   */
  fprintf(job->log, "%-13s > ", JOB_NAME(job));
  if (WIFEXITED(job->exit)) {
    if (!WEXITSTATUS(job->exit))
      { fputs("completed successfully\n", job->log); ok = 1; }
    else
      fprintf(job->log, "failed with exit status %d\n",
              WEXITSTATUS(job->exit));
  } else if (WIFSIGNALED(job->exit))
    fprintf(job->log, "killed by signal %d (%s%s)", WTERMSIG(job->exit),
#if defined(HAVE_STRSIGNAL)
        strsignal(WTERMSIG(job->exit)),
#elif defined(HAVE_DECL_SYS_SIGLIST)
        sys_siglist[WTERMSIG(job->exit)],
#else
        "unknown signal",
#endif
#ifdef WCOREDUMP
        WCOREDUMP(job->exit) ? "; core dumped" :
#endif
        "");
  else
    fprintf(job->log, "exited with incomprehensible status %06o\n",
            job->exit);

  /* If it succeeded, then try to rename the completed image file into place.
   *
   * If that caused trouble then mark the job as failed after all.
   */
  if (ok && rename(job->imgnew, job->imgout)) {
    fprintf(job->log, "%-13s > failed to rename Lisp `%s' "
                              "output image `%s' to `%s': %s",
            JOB_NAME(job), JOB_NAME(job),
            job->imgnew, job->imgout, strerror(errno));
    ok = 0;
  }

  /* If the job failed and we're being quiet then write out the log that we
   * made.
   */
  if (!ok && verbose < 2) {
    rewind(job->log);
    for (;;) {
      n = fread(buf, 1, sizeof(buf), job->log);
      if (n) fwrite(buf, 1, n, stdout);
      if (n < sizeof(buf)) break;
    }
  }

  /* Also make a node to stderr about what happened.  (Just to make sure
   * that we've gotten someone's attention.)
   */
  if (!ok) bad("failed to dump Lisp `%s'", JOB_NAME(job));

  /* Finally free the job control block. */
  release_job(job);
}

/* Called after `SIGCHLD': collect exit statuses and mark jobs as dead. */
static void reap_children(void)
{
  struct job *job, **link;
  pid_t kid;
  int st;

  for (;;) {

    /* Collect a child exit status.  If there aren't any more then we're
     * done.
     */
    kid = waitpid(0, &st, WNOHANG);
    if (kid <= 0) break;

    /* Try to find a matching job.  If we can't, then we should just ignore
     * it.
     */
    for (link = &job_run; (job = *link); link = &job->next)
      if (job->kid == kid) goto found;
    continue;

  found:
    /* Mark the job as dead, save its exit status, and move it into the dead
     * list.
     */
    job->exit = st; job->st = JST_DEAD; job->kid = -1; nrun--;
    *link = job->next; job->next = job_dead; job_dead = job;
  }

  /* If there was a problem with waitpid(2) then report it. */
  if (kid < 0 && errno != ECHILD)
    lose("failed to collect child process exit status: %s", strerror(errno));
}

/* Execute the handler for some JOB. */
static NORETURN void job_child(struct job *job)
{
  try_exec(&job->av,
           !(flags&AF_CHECKINST) && verbose >= 2 ? TEF_VERBOSE : 0);
  moan("failed to run `%s': %s", job->av.v[0], strerror(errno));
  _exit(127);
}

/* Start up jobs while there are (a) jobs to run and (b) slots to run them
 * in.
 */
static void start_jobs(void)
{
  struct dstr d = DSTR_INIT;
  int p_out[2], p_err[2];
  struct job *job;
  pid_t kid;

  /* Keep going until either we run out of jobs, or we've got enough running
   * already.
   */
  while (job_ready && nrun < maxrun) {

    /* Set things up ready.  If things go wrong, we need to know what stuff
     * needs to be cleaned up.
     */
    job = job_ready; job_ready = job->next;
    p_out[0] = p_out[1] = p_err[0] = p_err[1] = -1;

    /* Make a temporary subdirectory for this job to use. */
    dstr_reset(&d); dstr_putf(&d, "%s/%s", tmpdir, JOB_NAME(job));
    if (mkdir(d.p, 0700)) {
      bad("failed to create working directory for job `%s': %s",
          JOB_NAME(job), strerror(errno));
      goto fail;
    }

    /* Create the job's log file.  If we're being verbose then that's just
     * our normal standard output -- /not/ stderr: it's likely that users
     * will want to pipe this stuff through a pager or something, and that'll
     * be easier if we use stdout.  Otherwise, make a file in the temporary
     * directory.
     */
    if (verbose >= 2)
      job->log = stdout;
    else {
      dstr_puts(&d, "/log"); job->log = fopen(d.p, "w+");
      if (!job->log)
        lose("failed to open log file `%s': %s", d.p, strerror(errno));
    }

    /* Make the pipes to capture the child process's standard output and
     * error streams.
     */
    if (pipe(p_out) || pipe(p_err)) {
      bad("failed to create pipes for job `%s': %s",
          JOB_NAME(job), strerror(errno));
      goto fail;
    }
    if (configure_fd("job stdout pipe", p_out[0], 1, 1) ||
        configure_fd("job stdout pipe", p_out[1], 0, 1) ||
        configure_fd("job stderr pipe", p_err[0], 1, 1) ||
        configure_fd("job stderr pipe", p_err[1], 0, 1) ||
        configure_fd("log file", fileno(job->log), 1, 1))
      goto fail;

    /* Initialize the line-buffer structures ready for use. */
    job->out.buf = xmalloc(MAXLINE); job->out.off = job->out.len = 0;
    job->out.fd = p_out[0]; p_out[0] = -1;
    job->err.buf = xmalloc(MAXLINE); job->err.off = job->err.len = 0;
    job->err.fd = p_err[0]; p_err[0] = -1;
    dstr_reset(&d); argv_string(&d, &job->av);

    /* Print a note to the top of the log. */
    fprintf(job->log, "%-13s > starting %s\n", JOB_NAME(job), d.p);

    /* Flush the standard output stream.  (Otherwise the child might try to
     * flush it too.)
     */
    fflush(stdout);

    /* Spin up the child process. */
    kid = fork();
    if (kid < 0) {
      bad("failed to fork process for job `%s': %s",
          JOB_NAME(job), strerror(errno));
      goto fail;
    }
    if (!kid) {
      if (dup2(nullfd, 0) < 0 ||
          dup2(p_out[1], 1) < 0 ||
          dup2(p_err[1], 2) < 0)
        lose("failed to juggle job `%s' file descriptors: %s",
             JOB_NAME(job), strerror(errno));
      job_child(job);
    }

    /* Close the ends of the pipes that we don't need.  Move the job into
     * the running list.
     */
    close(p_out[1]); close(p_err[1]);
    job->kid = kid;
    job->st = JST_RUN; job->next = job_run; job_run = job; nrun++;
    continue;

  fail:
    /* Clean up the wreckage if it didn't work. */
    if (p_out[0] >= 0) close(p_out[0]);
    if (p_out[1] >= 0) close(p_out[1]);
    if (p_err[0] >= 0) close(p_err[0]);
    if (p_err[1] >= 0) close(p_err[1]);
    release_job(job);
  }

  /* All done except for some final tidying up. */
  dstr_release(&d);
}

/* Take care of all of the jobs until they're all done. */
static void run_jobs(void)
{
  struct job *job, *next, **link;
  int nfd;
  fd_set fd_in;

  for (;;) {

    /* If there are jobs still to be started and we have slots to spare then
     * start some more up.
     */
    start_jobs();

    /* If the queues are now all empty then we're done.  (No need to check
     * `job_ready' here: `start_jobs' would have started them if `job_run'
     * was empty.
     */
    if (!job_run && !job_dead) break;


    /* Prepare for the select(2) call: watch for the signal pipe and all of
     * the job pipes.
     */
#define SET_FD(dir, fd) do {                                            \
  int _fd = (fd);                                                       \
  FD_SET(_fd, &fd_##dir);                                               \
  if (_fd >= nfd) nfd = _fd + 1;                                        \
} while (0)

    FD_ZERO(&fd_in); nfd = 0;
    SET_FD(in, sig_pipe[0]);
    for (job = job_run; job; job = job->next) {
      if (job->out.fd >= 0) SET_FD(in, job->out.fd);
      if (job->err.fd >= 0) SET_FD(in, job->err.fd);
    }
    for (job = job_dead; job; job = job->next) {
      if (job->out.fd >= 0) SET_FD(in, job->out.fd);
      if (job->err.fd >= 0) SET_FD(in, job->err.fd);
    }

#undef SET_FD

    /* Find out what's going on. */
    if (select(nfd, &fd_in, 0, 0, 0) < 0) {
      if (errno == EINTR) continue;
      else lose("select failed: %s", strerror(errno));
    }

    /* If there were any signals then handle them. */
    if (FD_ISSET(sig_pipe[0], &fd_in)) {
      check_signals();
      if (sigloss >= 0) {
        /* We hit a fatal signal.  Kill off the remaining jobs and abort. */
        for (job = job_ready; job; job = next)
          { next = job->next; release_job(job); }
        for (job = job_run; job; job = next)
          { next = job->next; release_job(job); }
        for (job = job_dead; job; job = next)
          { next = job->next; release_job(job); }
        break;
      }
    }

    /* Log any new output from the running jobs. */
    for (job = job_run; job; job = job->next) {
      if (job->out.fd >= 0 && FD_ISSET(job->out.fd, &fd_in))
        prefix_lines(job, &job->out, '|');
      if (job->err.fd >= 0 && FD_ISSET(job->err.fd, &fd_in))
        prefix_lines(job, &job->err, '*');
    }

    /* Finally, clear away any dead jobs once we've collected all their
     * output.
     */
    for (link = &job_dead, job = *link; job; job = next) {
      next = job->next;
      if (job->out.fd >= 0 || job->err.fd >= 0) link = &job->next;
      else { *link = next; finish_job(job); }
    }
  }
}

/*----- Main program ------------------------------------------------------*/

/* Help and related functions. */
static void version(FILE *fp)
  { fprintf(fp, "%s, runlisp version %s\n", progname, PACKAGE_VERSION); }

static void usage(FILE *fp)
{
  fprintf(fp, "\
usage: %s [-afnqv] [-c CONF] [-o [SECT:]VAR=VAL]\n\
        [-O FILE|DIR] [-j NJOBS] [LISP ...]\n",
          progname);
}

static void help(FILE *fp)
{
  version(fp); fputc('\n', fp); usage(fp);
  fputs("\n\
Help options:\n\
  -h, --help                    Show this help text and exit successfully.\n\
  -V, --version                 Show version number and exit successfully.\n\
\n\
Diagnostics:\n\
  -n, --dry-run                 Don't run run anything (useful with `-v').\n\
  -q, --quiet                   Don't print warning messages.\n\
  -v, --verbose                 Print informational messages (repeatable).\n\
\n\
Configuration:\n\
  -c, --config-file=CONF        Read configuration from CONF (repeatable).\n\
  -o, --set-option=[SECT:]VAR=VAL Set configuration variable (repeatable).\n\
\n\
Image dumping:\n\
  -O, --output=FILE|DIR         Store image(s) in FILE or DIR.\n\
  -a, --all-configured          Dump all implementations configured.\n\
  -f, --force                   Dump images even if they already exist.\n\
  -i, --check-installed         Check Lisp systems exist before invoking.\n\
  -j, --jobs=NJOBS              Run up to NJOBS jobs in parallel.\n",
        fp);
}

/* Main program. */
int main(int argc, char *argv[])
{
  struct config_section_iter si;
  struct config_section *sect;
  struct config_var *var;
  const char *out = 0, *p, *q, *l;
  struct job *job, **tail;
  struct stat st;
  struct dstr d = DSTR_INIT;
  int i, fd, first;

  /* Command-line options. */
  static const struct option opts[] = {
    { "help",                   0,              0,      'h' },
    { "version",                0,              0,      'V' },
    { "output",                 OPTF_ARGREQ,    0,      'O' },
    { "all-configured",         0,              0,      'a' },
    { "config-file",            OPTF_ARGREQ,    0,      'c' },
    { "force",                  OPTF_NEGATE,    0,      'f' },
    { "check-installed",        OPTF_NEGATE,    0,      'i' },
    { "jobs",                   OPTF_ARGREQ,    0,      'j' },
    { "dry-run",                OPTF_NEGATE,    0,      'n' },
    { "set-option",             OPTF_ARGREQ,    0,      'o' },
    { "quiet",                  0,              0,      'q' },
    { "verbose",                0,              0,      'v' },
    { 0,                        0,              0,      0 }
  };

  /* Initial setup. */
  set_progname(argv[0]);
  init_config();

  /* Parse the options. */
  optprog = (/*unconst*/ char *)progname;
  for (;;) {
    i = mdwopt(argc - 1, argv + 1, "hVO:ac:f+i+j:n+o:qv", opts, 0, 0,
               OPTF_NEGATION | OPTF_NOPROGNAME);
    if (i < 0) break;
    switch (i) {
      case 'h': help(stdout); exit(0);
      case 'V': version(stdout); exit(0);
      case 'O': out = optarg; break;
      case 'a': flags |= AF_ALL; break;
      case 'c': read_config_path(optarg, 0); flags |= AF_SETCONF; break;
      case 'f': flags |= AF_FORCE; break;
      case 'f' | OPTF_NEGATED: flags &= ~AF_FORCE; break;
      case 'i': flags |= AF_CHECKINST; break;
      case 'i' | OPTF_NEGATED: flags &= ~AF_CHECKINST; break;
      case 'j': maxrun = parse_int("number of jobs", optarg, 1, 65535); break;
      case 'n': flags |= AF_DRYRUN; break;
      case 'n' | OPTF_NEGATED: flags &= ~AF_DRYRUN; break;
      case 'o': if (set_config_var(optarg)) flags |= AF_BOGUS; break;
      case 'q': if (verbose) verbose--; break;
      case 'v': verbose++; break;
      default: flags |= AF_BOGUS; break;
    }
  }

  /* CHeck that everything worked. */
  optind++;
  if ((flags&AF_ALL) ? optind < argc : optind >= argc) flags |= AF_BOGUS;
  if (flags&AF_BOGUS) { usage(stderr); exit(127); }

  /* Load default configuration if no explicit files were requested. */
  if (!(flags&AF_SETCONF)) load_default_config();

  /* OK, so we've probably got some work to do.  Let's set things up ready.
   * It'll be annoying if our standard descriptors aren't actually set up
   * properly, so we'll make sure those slots are populated.  We'll need a
   * `/dev/null' descriptor anyway (to be stdin for the jobs).  We'll also
   * need a temporary directory, and it'll be less temporary if we don't
   * arrange to delete it when we're done.  And finally we'll need to know
   * when a child process exits.
   */
  for (;;) {
    fd = open("/dev/null", O_RDWR);
    if (fd < 0) lose("failed to open `/dev/null': %s", strerror(errno));
    if (fd > 2) { nullfd = fd; break; }
  }
  configure_fd("null fd", nullfd, 0, 1);
  atexit(cleanup);
  if (pipe(sig_pipe))
    lose("failed to create signal pipe: %s", strerror(errno));
  configure_fd("signal pipe (read end)", sig_pipe[0], 1, 1);
  configure_fd("signal pipe (write end)", sig_pipe[1], 1, 1);
  sigemptyset(&caught); sigemptyset(&pending);
  set_signal_handler("SIGTERM", SIGTERM, SIGF_IGNOK);
  set_signal_handler("SIGINT", SIGINT, SIGF_IGNOK);
  set_signal_handler("SIGHUP", SIGHUP, SIGF_IGNOK);
  set_signal_handler("SIGCHLD", SIGCHLD, 0);

  /* Create the temporary directory and export it into the configuration. */
  set_tmpdir();
  config_set_var(&config, builtin, CF_LITERAL, "@%tmp-dir", tmpdir);
  config_set_var(&config, builtin, 0,
                 "@tmp-dir", "${@BUILTIN:@%tmp-dir}/${@name}");

  /* Work out where the image files are going to go.  If there's no `-O'
   * option then we use the main `image-dir'.  Otherwise what happens depends
   * on whether this is a file or a directory.
   */
  if (!out)
    config_set_var(&config, builtin, 0,
                   "@image-out", "${@image-dir}/${image-file}");
  else if (!stat(out, &st) && S_ISDIR(st.st_mode))  {
    config_set_var(&config, builtin, CF_LITERAL, "@%out-dir", out);
    config_set_var(&config, builtin, 0,
                   "@image-out", "${@BUILTIN:@%out-dir}/${image-file}");
  } else if (argc - optind != 1)
    lose("can't dump multiple Lisps to a single output file");
  else
    config_set_var(&config, builtin, CF_LITERAL, "@image-out", out);

  /* Set the staging file. */
  config_set_var(&config, builtin, 0, "@image-new", "${@image-out}.new");

  /* Dump the final configuration if we're being very verbose. */
  if (verbose >= 5) dump_config();

  /* Create jobs for the Lisp systems we're supposed to be dumping. */
  tail = &job_ready;
  if (!(flags&AF_ALL))
    for (i = optind; i < argc; i++)
      add_job(&tail, 0, argv[i], strlen(argv[i]));
  else {
    /* So we're supposed to dump `all' of them.  If there's a `dump'
     * configuration setting then we need to parse that.  Otherwise we just
     * try all of them.
     */
    var = config_find_var(&config, toplevel, 0, "dump");
    if (!var) {
      /* No setting.  Just do all of the Lisps which look available. */

      flags |= AF_CHECKINST;
      for (config_start_section_iter(&config, &si);
           (sect = config_next_section(&si)); )
        add_job(&tail, JF_QUIET,
                CONFIG_SECTION_NAME(sect),
                CONFIG_SECTION_NAMELEN(sect));
    } else {
      /* Parse the `dump' list. */

      p = var->val; l = p + var->n;
      for (;;) {
        while (p < l && ISSPACE(*p)) p++;
        if (p >= l) break;
        q = p;
        while (p < l && !ISSPACE(*p) && *p != ',') p++;
        add_job(&tail, 0, q, p - q);
        while (p < l && ISSPACE(*p)) p++;
        if (p < l && *p == ',') p++;
      }
    }
  }
  *tail = 0;

  /* Report on what it is we're about to do. */
  if (verbose >= 3) {
    dstr_reset(&d);
    first = 1;
    for (job = job_ready; job; job = job->next) {
      if (first) first = 0;
      else dstr_puts(&d, ", ");
      dstr_putf(&d, "`%s'", JOB_NAME(job));
    }
    if (first) dstr_puts(&d, "(none)");
    dstr_putz(&d);
    moan("dumping Lisps: %s", d.p);
  }

  /* If we're not actually going to do anything after all then now's the time
   * to, err, not do that.
   */
  if (flags&AF_DRYRUN) {
    for (job = job_ready; job; job = job->next) {
      if (try_exec(&job->av,
                   TEF_DRYRUN |
                     (verbose >= 2 && !(flags&AF_CHECKINST) ?
                       TEF_VERBOSE : 0)))
        rc = 2;
      else if (verbose >= 2)
        printf("%-13s > (not dumping `%s': dry run)\n",
                JOB_NAME(job), JOB_NAME(job));
    }
    return (rc);
  }

  /* Run the jobs. */
  run_jobs();

  /* Finally, check for any last signals.  If we hit any fatal signals then
   * we should kill ourselves so that the exit status will be right.
   */
  check_signals();
  if (sigloss) { cleanup(); signal(sigloss, SIG_DFL); raise(sigloss); }

  /* All done! */
  return (rc);
}

/*----- That's all, folks -------------------------------------------------*/