/* -*- Mode: C; c-basic-offset: 2; indent-tabs-mode: nil -*- */
/* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */

/*
 * unixint.d -- Unix interrupt interface.
 *
 * Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya.
 * Copyright (c) 1990, Giuseppe Attardi.
 * Copyright (c) 2001, Juan Jose Garcia Ripoll.
 * Copyright (c) 2016, Daniel Kochmański.
 *
 * See file 'LICENSE' for the copyright details.
 *
*/

/**********************************************************************
 * HOW WE HANDLE SIGNALS AND EXCEPTIONS
 *
 * (the following should be correlated with the manual)
 *
 * POSIX contemplates the notion of "signals", which are events that
 * cause a process or a thread to be interrupted. Windows uses the
 * term "exception", which includes also a more general kind of
 * errors.
 *
 * In both cases the consequence is that a thread or process may be
 * interrupted at any time, either by causes which are intrinsic to
 * them (synchronous signals), such as floating point exceptions, or
 * extrinsic (asynchronous signals), such as the process being aborted
 * by the user.
 *
 * Of course, those interruptions are not always welcome. When the
 * interrupt is delivered and a handler is invoked, the thread or even
 * the whole program may be in an inconsistent state. For instance the
 * thread may have acquired a lock, or it may be in the process of
 * filling the fields of a structure. Understanding this POSIX
 * restricts severely what functions can be called from a signal
 * handler, thereby limiting its usefulness.
 *
 * There is a simple solution, which ECL uses, and which is to mark
 * sections of code which are interruptible, and in which it is safe
 * for the handler to run arbitrary code, protect anything else. In
 * principle this "marking" can be done using POSIX functions such as
 * pthread_sigmask() or sigprocmask().
 *
 * However in practice this is slow, as it involves at least a
 * function call, resolving thread-local variables, etc, etc, and it
 * will not work in Windows. Furthermore, sometimes we want signals to
 * be detected but not to be immediately processed. For instance, when
 * reading from the terminal we want to be able to interrupt the
 * process, but we can not execute the code from the handler, since
 * read() may leave the input stream in an inconsistent, or even
 * locked state.
 *
 * Our approach is slightly different: we install our own signal
 * hander which reads a single, thread-local variable stored in the
 * ecl_process_env()->disable_interrupts. If the variable marks that
 * signals should be postponed, then the information about the signal
 * is queued. Otherwise the appropriate code is executed: for instance
 * invoking the debugger, jumping to a condition handler, quitting,
 * etc.
 */

#ifdef __sun__
/* For SA_SIGINFO in Solaris. We could have used _XOPEN_SOURCE=600, but
 * this requires C99 and the default GCC for Solaris (3.4.3) does not
 * support this C standard. */
# define __EXTENSIONS__
#endif
#include <errno.h>
#include <string.h>
#include <stdio.h>
#include <signal.h>

#if defined(_MSC_VER) || defined(__MINGW32__)
# include <windows.h>
#endif
#if !defined(_MSC_VER)
# include <unistd.h>
#endif

#include <ecl/ecl.h>

#ifdef ECL_USE_MPROTECT
# ifndef SA_SIGINFO
#  error "We cannot use the mmap code without siginfo"
# endif
# include <sys/mman.h>
#endif

#include <ecl/internal.h>
#include <ecl/ecl-inl.h>
#include <ecl/impl/math_fenv.h>

static struct {
  int code;
  char *name;
  cl_object handler;
} known_signals[] = {
#ifdef SIGHUP
  { SIGHUP, "+SIGHUP+", ECL_NIL},
#endif
#ifdef SIGINT
  { SIGINT, "+SIGINT+", @'si::terminal-interrupt'},
#endif
#ifdef SIGQUIT
  { SIGQUIT, "+SIGQUIT+", ECL_NIL},
#endif
#ifdef SIGILL
  { SIGILL, "+SIGILL+", @'ext::illegal-instruction'},
#endif
#ifdef SIGTRAP
  { SIGTRAP, "+SIGTRAP+", ECL_NIL},
#endif
#ifdef SIGABRT
  { SIGABRT, "+SIGABRT+", ECL_NIL},
#endif
#ifdef SIGEMT
  { SIGEMT, "+SIGEMT+", ECL_NIL},
#endif
#ifdef SIGFPE
  { SIGFPE, "+SIGFPE+", ECL_NIL},
#endif
#ifdef SIGKILL
  { SIGKILL, "+SIGKILL+", ECL_NIL},
#endif
#ifdef SIGBUS
  { SIGBUS, "+SIGBUS+", @'ext::segmentation-violation'},
#endif
#ifdef SIGSEGV
  { SIGSEGV, "+SIGSEGV+", @'ext::segmentation-violation'},
#endif
#ifdef SIGSYS
  { SIGSYS, "+SIGSYS+", ECL_NIL},
#endif
#ifdef SIGPIPE
  { SIGPIPE, "+SIGPIPE+", ECL_NIL},
#endif
#ifdef SIGALRM
  { SIGALRM, "+SIGALRM+", ECL_NIL},
#endif
#ifdef SIGTERM
  { SIGTERM, "+SIGTERM+", ECL_NIL},
#endif
#ifdef SIGURG
  { SIGURG, "+SIGURG+", ECL_NIL},
#endif
#ifdef SIGSTOP
  { SIGSTOP, "+SIGSTOP+", ECL_NIL},
#endif
#ifdef SIGTSTP
  { SIGTSTP, "+SIGTSTP+", ECL_NIL},
#endif
#ifdef SIGCONT
  { SIGCONT, "+SIGCONT+", ECL_NIL},
#endif
#ifdef SIGCHLD
  { SIGCHLD, "+SIGCHLD+", ECL_NIL},
#endif
#ifdef SIGTTIN
  { SIGTTIN, "+SIGTTIN+", ECL_NIL},
#endif
#ifdef SIGTTOU
  { SIGTTOU, "+SIGTTOU+", ECL_NIL},
#endif
#ifdef SIGIO
  { SIGIO, "+SIGIO+", ECL_NIL},
#endif
#ifdef SIGXCPU
  { SIGXCPU, "+SIGXCPU+", ECL_NIL},
#endif
#ifdef SIGXFSZ
  { SIGXFSZ, "+SIGXFSZ+", ECL_NIL},
#endif
#ifdef SIGVTALRM
  { SIGVTALRM, "+SIGVTALRM+", ECL_NIL},
#endif
#ifdef SIGPROF
  { SIGPROF, "+SIGPROF+", ECL_NIL},
#endif
#ifdef SIGWINCH
  { SIGWINCH, "+SIGWINCH+", ECL_NIL},
#endif
#ifdef SIGINFO
  { SIGINFO, "+SIGINFO+", ECL_NIL},
#endif
#ifdef SIGUSR1
  { SIGUSR1, "+SIGUSR1+", ECL_NIL},
#endif
#ifdef SIGUSR2
  { SIGUSR2, "+SIGUSR2+", ECL_NIL},
#endif
#ifdef SIGTHR
  { SIGTHR, "+SIGTHR+", ECL_NIL},
#endif
  { -1, "", ECL_NIL }
};

#ifdef HAVE_SIGPROCMASK
static sigset_t main_thread_sigmask;
# define handler_fn_prototype(name, sig, info, aux) name(sig, info, aux)
# define call_handler(name, sig, info, aux) name(sig, info, aux)
# define reinstall_signal(x,y)
# define copy_siginfo(x,y) memcpy(x, y, sizeof(struct sigaction))
static void
mysignal(int code, void *handler)
{
  struct sigaction action;
  sigaction(code, NULL, &action);
  if (handler == SIG_IGN || handler == SIG_DFL) {
    action.sa_handler = handler;
  } else {
#ifdef SA_SIGINFO
    /* void (*handler)(int, siginfo_t *, void*) */
    action.sa_sigaction = handler;
    action.sa_flags = SA_SIGINFO;
#else
    /* void (*handler)(int) */
    action.sa_handler = handler;
    action.sa_flags = 0;
#endif
    sigfillset(&action.sa_mask);
  }
  sigaction(code, &action, NULL);
}
#else /* HAVE_SIGPROCMASK */
# define handler_fn_prototype(name, sig, info, aux) name(sig)
# define call_handler(name, sig, info, aux) name(sig)
# define mysignal(x,y) signal(x,y)
# define reinstall_signal(x,y) signal(x,y)
# define copy_siginfo(x,y)
#endif

static bool
zombie_process(cl_env_ptr the_env)
{
#ifdef ECL_THREADS
  if (the_env == NULL) {
    return 1;
  } else {
    /* When we are exiting a thread, we simply ignore all signals. */
    cl_object process = the_env->own_process;
    return (process->process.phase == ECL_PROCESS_INACTIVE);
  }
#else
  return !the_env;
#endif
}

static ECL_INLINE bool
interrupts_disabled_by_C(cl_env_ptr the_env)
{
  return the_env->disable_interrupts;
}

static ECL_INLINE bool
interrupts_disabled_by_lisp(cl_env_ptr the_env)
{
  return !ecl_option_values[ECL_OPT_BOOTED] ||
    Null(ECL_SYM_VAL(the_env, @'ext::*interrupts-enabled*'));
}

static void early_signal_error() ecl_attr_noreturn;

static void
early_signal_error()
{
  ecl_internal_error("Got signal before environment was installed"
                     " on our thread");
}

static void illegal_signal_code(cl_object code) ecl_attr_noreturn;

static void
illegal_signal_code(cl_object code)
{
  FEerror("Unknown signal code: ~D", 1, code);
}

/* On platforms in which mprotect() works, we block all write access
 * to the environment for a cheap check of pending interrupts. On
 * other platforms we change the value of disable_interrupts to 3, so
 * that we detect changes. */
static ECL_INLINE void
set_guard_page(cl_env_ptr the_env)
{
#if defined(ECL_USE_MPROTECT)
  if (mprotect(the_env, sizeof(*the_env), PROT_READ) < 0) {
    ecl_internal_error("Unable to mprotect environment.");
  }
#elif defined(ECL_USE_GUARD_PAGE)
  if (!VirtualProtect(the_env, sizeof(*the_env), PAGE_GUARD, NULL)) {
    ecl_internal_error("Unable to mprotect environment.");
  }
#endif
}

static cl_object pop_signal(cl_env_ptr env);

#define unblock_signal(env, sig)
#ifdef HAVE_SIGPROCMASK
# undef unblock_signal
static void
unblock_signal(cl_env_ptr the_env, int signal)
{
  /*
   * We do not really "unblock" the signal, but rather restore
   * ECL's default sigmask.
   */
# ifdef ECL_THREADS
  pthread_sigmask(SIG_SETMASK, the_env->default_sigmask, NULL);
# else
  sigprocmask(SIG_SETMASK, the_env->default_sigmask, NULL);
# endif
}
#endif

ecl_def_ct_base_string(str_ignore_signal,"Ignore signal",13,static,const);

static void
handle_signal_now(cl_object signal_code)
{
  switch (ecl_t_of(signal_code)) {
  case t_fixnum:
    cl_cerror(4, str_ignore_signal, @'ext::unix-signal-received',
              @':code', signal_code);
    break;
  case t_symbol:
    /*
     * When we bind a handler to a signal, it may either
     * be a function, a symbol denoting a function or
     * a symbol denoting a condition.
     */
    if (cl_find_class(2, signal_code, ECL_NIL) != ECL_NIL) {
      cl_cerror(2, str_ignore_signal, signal_code);
      break;
    }
    /* fallthrough */
  case t_cfun:
  case t_cfunfixed:
  case t_cclosure:
  case t_bytecodes:
  case t_bclosure:
    _ecl_funcall1(signal_code);
  default:
    break;
  }
}

cl_object
si_handle_signal(cl_object signal_code)
{
  const cl_env_ptr the_env = ecl_process_env();
  handle_signal_now(signal_code);
  ecl_return0(the_env);
}

static void
handle_all_queued(cl_env_ptr env)
{
  while (env->interrupt_struct->pending_interrupt != ECL_NIL) {
    handle_signal_now(pop_signal(env));
  }
}

static void
handle_all_queued_interrupt_safe(cl_env_ptr env)
{
  /* We have to save and later restore thread-local variables to
   * ensure that they don't get overwritten by the interrupting
   * code */
  /* INV: - IHS stack manipulations are interrupt safe
   *      - The rest of the thread local variables are
   *        guaranteed to be used in an interrupt safe way. This
   *        is not true for the compiler environment and ffi
   *        data, but it is unclear whether the DFFI or compiler
   *        are thread safe anyway. */
  cl_object fun = env->function;
  cl_index nvalues = env->nvalues;
  cl_object values[ECL_MULTIPLE_VALUES_LIMIT];
  memcpy(values, env->values, ECL_MULTIPLE_VALUES_LIMIT*sizeof(cl_object));
  cl_object stack_frame = env->stack_frame;
  cl_object packages_to_be_created = env->packages_to_be_created;
  cl_object packages_to_be_created_p = env->packages_to_be_created_p;
  /* bignum registers need some special handling, because their
   * contents are allocated as uncollectable memory. If we did
   * not init and clear them before calling the interrupting
   * code we would risk memory leaks. */
  cl_object big_register[ECL_BIGNUM_REGISTER_NUMBER];
  memcpy(big_register, env->big_register, ECL_BIGNUM_REGISTER_NUMBER*sizeof(cl_object));
  ecl_init_bignum_registers(env);
  /* We might have been interrupted while we push/pop in the stack. Increasing
   * env->run_stack.top ensures that we don't overwrite the topmost stack
   * value. */
  env->run_stack.top++;
  /* We also need to save and restore the (top+1)'th frame and
   * binding stack value to prevent overwriting it.
   * INV: Due to the stack safety areas we don't need to check
   * for env->frs/bds_limit */
  struct ecl_frame top_frame;
  memcpy(&top_frame, env->frs_stack.top+1, sizeof(struct ecl_frame));
  struct ecl_bds_frame top_binding;
  memcpy(&top_binding, env->bds_stack.top+1, sizeof(struct ecl_bds_frame));
  /* Finally we can handle the queued signals ... */
  handle_all_queued(env);
  /* ... and restore everything again */
  memcpy(env->bds_stack.top+1, &top_binding, sizeof(struct ecl_bds_frame));
  memcpy(env->frs_stack.top+1, &top_frame, sizeof(struct ecl_frame));
  env->run_stack.top--;
  ecl_clear_bignum_registers(env);
  memcpy(env->big_register, big_register, ECL_BIGNUM_REGISTER_NUMBER*sizeof(cl_object));
  env->packages_to_be_created_p = packages_to_be_created_p;
  env->packages_to_be_created = packages_to_be_created;
  env->stack_frame = stack_frame;
  memcpy(env->values, values, ECL_MULTIPLE_VALUES_LIMIT*sizeof(cl_object));
  env->nvalues = nvalues;
  env->function = fun;
}

static void
queue_signal(cl_env_ptr env, cl_object code, int allocate)
{
  /* Note: We don't use ECL_WITH_NATIVE_LOCK_BEGIN/END here
   * since it checks for pending interrupts after unlocking the
   * mutex. This would lead to the interrupt being handled
   * immediately when queueing an interrupt for the current
   * thread, even when interrupts are disabled. */

  /* INV: interrupts are disabled, therefore the lock will
   * always be released */
#ifdef ECL_THREADS
  ecl_mutex_lock(&env->interrupt_struct->signal_queue_lock);
#endif

  cl_object record;
  if (allocate) {
    record = ecl_list1(ECL_NIL);
  } else {
    record = env->interrupt_struct->signal_queue;
    if (record != ECL_NIL) {
      env->interrupt_struct->signal_queue = ECL_CONS_CDR(record);
    }
  }
  if (record != ECL_NIL) {
    ECL_RPLACA(record, code);
    ECL_RPLACD(record, ECL_NIL);
    env->interrupt_struct->pending_interrupt =
      ecl_nconc(env->interrupt_struct->pending_interrupt, record);
  }

#ifdef ECL_THREADS
  ecl_mutex_unlock(&env->interrupt_struct->signal_queue_lock);
#endif
}

static cl_object
pop_signal(cl_env_ptr env)
{
  cl_object record, value;
  /* Note: We don't use ECL_WITH_NATIVE_LOCK_BEGIN/END here
   * since it checks for pending interrupts after unlocking the
   * mutex. This would lead to handle_all_queued and pop_signal
   * being called again and the interrupts being handled in the
   * wrong order. */

  ecl_disable_interrupts_env(env);
#ifdef ECL_THREADS
  ecl_mutex_lock(&env->interrupt_struct->signal_queue_lock);
#endif

  if (env->interrupt_struct->pending_interrupt == ECL_NIL) {
    value = ECL_NIL;
  } else {
    record = env->interrupt_struct->pending_interrupt;
    value = ECL_CONS_CAR(record);
    env->interrupt_struct->pending_interrupt = ECL_CONS_CDR(record);
    /* Save some conses for future use, to avoid allocating */
    if (ECL_SYMBOLP(value) || ECL_FIXNUMP(value)) {
      ECL_RPLACD(record, env->interrupt_struct->signal_queue);
      env->interrupt_struct->signal_queue = record;
    }
  }

#ifdef ECL_THREADS
  ecl_mutex_unlock(&env->interrupt_struct->signal_queue_lock);
#endif
  ecl_enable_interrupts_env(env);
  return value;
}

static void
handle_or_queue(cl_env_ptr the_env, cl_object signal_code, int code)
{
  if (Null(signal_code) || signal_code == NULL)
    return;
  /*
   * If interrupts are disabled by lisp we are not so eager on
   * detecting when the interrupts become enabled again. We
   * queue the signal and are done with that.
   */
  if (interrupts_disabled_by_lisp(the_env)) {
    queue_signal(the_env, signal_code, 0);
  }
  /*
   * If interrupts are disabled by C, and we have not pushed a
   * pending signal, save this signal and return.
   */
  else if (interrupts_disabled_by_C(the_env)) {
    the_env->disable_interrupts = 3;
    queue_signal(the_env, signal_code, 0);
    set_guard_page(the_env);
  }
  /*
   * If interrupts are enabled, that means we are in a safe area
   * and may execute arbitrary lisp code. We can thus call the
   * appropriate handlers.
   */
  else {
    if (code) unblock_signal(the_env, code);
    si_trap_fpe(@'last', ECL_T); /* Clear FPE exception flag */
    handle_signal_now(signal_code);
  }
}

static void
handler_fn_prototype(non_evil_signal_handler, int sig, siginfo_t *siginfo, void *data)
{
  int old_errno = errno;
  cl_env_ptr the_env;
  cl_object signal_object;
  reinstall_signal(sig, non_evil_signal_handler);
  /* The lisp environment might not be installed. */
  the_env = ecl_process_env();
  unlikely_if (zombie_process(the_env))
    return;
  signal_object = ecl_gethash_safe(ecl_make_fixnum(sig),
                                   cl_core.known_signals,
                                   ECL_NIL);
  handle_or_queue(the_env, signal_object, sig);
  errno = old_errno;
}

static void
handler_fn_prototype(evil_signal_handler, int sig, siginfo_t *siginfo, void *data)
{
  int old_errno = errno;
  cl_env_ptr the_env;
  cl_object signal_object;
  reinstall_signal(sig, evil_signal_handler);
  /* The lisp environment might not be installed. */
  the_env = ecl_process_env();
  unlikely_if (zombie_process(the_env))
    return;
  signal_object = ecl_gethash_safe(ecl_make_fixnum(sig),
                                   cl_core.known_signals,
                                   ECL_NIL);
  handle_signal_now(signal_object);
  errno = old_errno;
}

#if defined(ECL_THREADS) && defined(HAVE_SIGPROCMASK)
typedef struct {
  cl_object process;
  int signo;
} signal_thread_message;
static cl_object signal_thread_process = ECL_NIL;
static signal_thread_message signal_thread_msg;
static ecl_mutex_t signal_thread_lock;
static int signal_thread_pipe[2] = {-1,-1};

static void
handler_fn_prototype(deferred_signal_handler, int sig, siginfo_t *siginfo, void *data)
{
  int old_errno = errno;
  cl_env_ptr the_env;
  signal_thread_message msg;
  reinstall_signal(sig, deferred_signal_handler);
  /* The lisp environment might not be installed. */
  the_env = ecl_process_env();
  unlikely_if (zombie_process(the_env))
    return;
  msg.signo = sig;
  msg.process = the_env->own_process;
  if (msg.process == signal_thread_process) {
    /* The signal handling thread may also receive signals. In
     * this case we do not use the pipe, but just copy the message
     * Note that read() will abort the thread will get notified. */
    signal_thread_msg = msg;
  } else if (signal_thread_pipe[1] > 0) {
    ecl_mutex_lock(&signal_thread_lock);
    write(signal_thread_pipe[1], &msg, sizeof(msg));
    ecl_mutex_unlock(&signal_thread_lock);
  } else {
    /* Nothing to do. There is no way to handle this signal because
     * the responsible thread is not running */
  }
  errno = old_errno;
}

static cl_object
asynchronous_signal_servicing_thread()
{
  const cl_env_ptr the_env = ecl_process_env();
  int interrupt_signal = -1;
  /*
   * We block all signals except the usual interrupt thread and
   * GC signals (including SIGSEGV and SIGSEGV which are needed
   * when the GC runs in incremental mode).
   */
  {
    sigset_t handled_set;
    sigfillset(&handled_set);
    if (ecl_option_values[ECL_OPT_TRAP_INTERRUPT_SIGNAL]) {
      interrupt_signal =
        ecl_option_values[ECL_OPT_THREAD_INTERRUPT_SIGNAL];
      sigdelset(&handled_set, interrupt_signal);
      sigdelset(&handled_set, GC_get_suspend_signal());
      sigdelset(&handled_set, GC_get_thr_restart_signal());
      sigdelset(&handled_set, SIGSEGV);
      sigdelset(&handled_set, SIGBUS);
    }
    pthread_sigmask(SIG_BLOCK, &handled_set, NULL);
  }
  /*
   * We create the object for communication. We need a lock to prevent other
   * threads from writing before the pipe is created.
   */
  ecl_mutex_lock(&signal_thread_lock);
  pipe(signal_thread_pipe);
  ecl_mutex_unlock(&signal_thread_lock);
  signal_thread_msg.process = ECL_NIL;
  for (;;) {
    cl_object signal_code;
    signal_thread_msg.process = ECL_NIL;
    if (read(signal_thread_pipe[0], &signal_thread_msg,
             sizeof(signal_thread_msg)) < 0)
      {
        /* Either the pipe errs or we have received an interrupt
         * from a different thread */
        if (errno != EINTR ||
            signal_thread_msg.process != the_env->own_process)
          break;
      }
    /* We have queued ourselves an interrupt event */
    if (signal_thread_msg.signo == interrupt_signal &&
        signal_thread_msg.process == the_env->own_process) {
      break;
    }
    signal_code = ecl_gethash_safe(ecl_make_fixnum(signal_thread_msg.signo),
                                   cl_core.known_signals,
                                   ECL_NIL);
    if (!Null(signal_code)) {
      mp_process_run_function(3, @'si::handle-signal',
                              @'si::handle-signal',
                              signal_code);
    }
  }
# if defined(ECL_USE_MPROTECT)
  /* We might have protected our own environment */
  mprotect(the_env, sizeof(*the_env), PROT_READ | PROT_WRITE);
# endif /* ECL_USE_MPROTECT */
  close(signal_thread_pipe[0]);
  close(signal_thread_pipe[1]);
  ecl_return0(the_env);
}
#endif /* ECL_THREADS && !ECL_MS_WINDOWS_HOST */

#if defined(ECL_THREADS) && !defined(ECL_MS_WINDOWS_HOST)
static void
handler_fn_prototype(process_interrupt_handler, int sig, siginfo_t *siginfo, void *data)
{
  int old_errno = errno;
  cl_env_ptr the_env;
  reinstall_signal(sig, process_interrupt_handler);
  /* The lisp environment might not be installed. */
  the_env = ecl_process_env();
  if (zombie_process(the_env))
    return;
  if (!Null(the_env->interrupt_struct->pending_interrupt)) {
    if (interrupts_disabled_by_C(the_env)) {
      set_guard_page(the_env);
    } else if (!interrupts_disabled_by_lisp(the_env)) {
      unblock_signal(the_env, sig);
      handle_all_queued_interrupt_safe(the_env);
    }
  }
  errno = old_errno;
}
#endif /* ECL_THREADS && !ECL_MS_WINDOWS_HOST */

static void
handler_fn_prototype(fpe_signal_handler, int sig, siginfo_t *info, void *data)
{
  int code;
  cl_object condition;
  cl_env_ptr the_env;
  reinstall_signal(sig, fpe_signal_handler);
  /* The lisp environment might not be installed. */
  unlikely_if (!ecl_option_values[ECL_OPT_BOOTED]) {
    early_signal_error();
  }
  the_env = ecl_process_env();
  unlikely_if (zombie_process(the_env))
    return;
  condition = @'arithmetic-error';
  code = 0;
#ifdef _MSC_VER
  switch (_fpecode) {
  case _FPE_INVALID:
    condition = @'floating-point-invalid-operation';
    code = FE_INVALID;
    break;
  case _FPE_OVERFLOW:
    condition = @'floating-point-overflow';
    code = FE_OVERFLOW;
    break;
  case _FPE_UNDERFLOW:
    condition = @'floating-point-underflow';
    code = FE_UNDERFLOW;
    break;
  case _FPE_ZERODIVIDE:
    condition = @'division-by-zero';
    code = FE_DIVBYZERO;
    break;
  }
#else /* !_MSC_VER */
# if defined(HAVE_FENV_H) & !defined(ECL_AVOID_FENV_H)
  code = fetestexcept(FE_ALL_EXCEPT);
  if (code & FE_DIVBYZERO) {
    condition = @'division-by-zero';
    code = FE_DIVBYZERO;
  } else if (code & FE_INVALID) {
    condition = @'floating-point-invalid-operation';
    code = FE_INVALID;
  } else if (code & FE_OVERFLOW) {
    condition = @'floating-point-overflow';
    code = FE_OVERFLOW;
  } else if (code & FE_UNDERFLOW) {
    condition = @'floating-point-underflow';
    code = FE_UNDERFLOW;
  } else if (code & FE_INEXACT) {
    condition = @'floating-point-inexact';
    code = FE_INEXACT;
  }
  feclearexcept(FE_ALL_EXCEPT);
# endif
#endif /* !_MSC_VER */
#if defined(SA_SIGINFO) && !defined(NACL)
  if (info) {
    if (info->si_code == FPE_INTDIV || info->si_code == FPE_FLTDIV) {
      condition = @'division-by-zero';
      code = FE_DIVBYZERO;
    } else if (info->si_code == FPE_FLTOVF) {
      condition = @'floating-point-overflow';
      code = FE_OVERFLOW;
    } else if (info->si_code == FPE_FLTUND) {
      condition = @'floating-point-underflow';
      code = FE_UNDERFLOW;
    } else if (info->si_code == FPE_FLTRES) {
      condition = @'floating-point-inexact';
      code = FE_INEXACT;
    } else if (info->si_code == FPE_FLTINV) {
      condition = @'floating-point-invalid-operation';
      code = FE_INVALID;
    }
  }
#endif /* SA_SIGINFO */
  /*
    if (code && !(code & the_env->trap_fpe_bits))
    condition = ECL_NIL;
  */
  si_trap_fpe(@'last', ECL_T); /* Clear FPE exception flag */
  unblock_signal(the_env, code);
  handle_signal_now(condition);
  /* We will not reach past this point. */
}

static void
handler_fn_prototype(sigsegv_handler, int sig, siginfo_t *info, void *aux)
{
  int old_errno = errno;
  static const char *stack_overflow_msg =
    "\n;;;\n;;; Stack overflow.\n"
    ";;; Jumping to the outermost toplevel prompt\n"
    ";;;\n\n";
  static const char *segv_msg =
    "\n;;;\n"
    ";;; Detected access to protected memory, "
    "also known as 'bus or segmentation fault'.\n"
    ";;; Jumping to the outermost toplevel prompt\n"
    ";;;\n\n";
  static const char *interrupt_msg =
    "\n;;;\n;;; Internal error:\n"
    ";;; Detected write access to the environment while "
    "interrupts were disabled. Usually this is caused by "
    "a missing call to ecl_enable_interrupts.\n"
    ";;;\n\n";
  cl_env_ptr the_env;
  reinstall_signal(sig, sigsegv_handler);
  /* The lisp environment might not be installed. */
  unlikely_if (!ecl_option_values[ECL_OPT_BOOTED]) {
    early_signal_error();
  }
  the_env = ecl_process_env();
  unlikely_if (zombie_process(the_env))
    return;
#if defined(SA_SIGINFO) && !defined(NACL)
# if defined(ECL_USE_MPROTECT)
  /* We access disable_interrupts when the environment was
   * protected. That means there was a pending signal. */
  if (((char*)&the_env->disable_interrupts <= (char*)info->si_addr) &&
      ((char*)info->si_addr < (char*)(&the_env->disable_interrupts+1)))
    {
      unblock_signal(the_env, sig);
      mprotect(the_env, sizeof(*the_env), PROT_READ | PROT_WRITE);
      the_env->disable_interrupts = 0;
      handle_all_queued_interrupt_safe(the_env);
      return;
    } else if (the_env->disable_interrupts &&
               ((char*)(&the_env->disable_interrupts+1) <= (char*)info->si_addr) &&
               ((char*)info->si_addr < (char*)(the_env+1))) {
    unblock_signal(the_env, sig);
    mprotect(the_env, sizeof(*the_env), PROT_READ | PROT_WRITE);
    the_env->disable_interrupts = 0;
    ecl_unrecoverable_error(the_env, interrupt_msg);
    return;
  }
# endif /* ECL_USE_MPROTECT */
# ifdef ECL_DOWN_STACK
  if (sig == SIGSEGV &&
      (char*)info->si_addr > the_env->c_stack.max &&
      (char*)info->si_addr <= the_env->c_stack.org) {
    unblock_signal(the_env, sig);
    ecl_unrecoverable_error(the_env, stack_overflow_msg);
    return;
  }
# else
  if (sig == SIGSEGV &&
      (char*)info->si_addr < the_env->c_stack.max &&
      (char*)info->si_addr >= the_env->c_stack.org) {
    unblock_signal(the_env, sig);
    ecl_unrecoverable_error(the_env, stack_overflow_msg);
    return;
  }
# endif /* ECL_DOWN_STACK */
        /* Do not attempt an error handler if we nest two serious 
         * errors in the same thread */
  if (the_env->fault_address == info->si_addr) {
    the_env->fault_address = info->si_addr;
    unblock_signal(the_env, sig);
    ecl_unrecoverable_error(the_env, segv_msg);
  } else {
    the_env->fault_address = info->si_addr;
    handle_or_queue(the_env, @'ext::segmentation-violation', sig);
  }
#else
  /*
   * We cannot distinguish between a stack overflow and a simple
   * access violation. Thus we assume the worst case and jump to
   * the outermost handler.
   */
  unblock_signal(the_env, sig);
  ecl_unrecoverable_error(the_env, segv_msg);
#endif /* SA_SIGINFO */
  errno = old_errno;
}

cl_object
si_check_pending_interrupts(void)
{
  const cl_env_ptr the_env = ecl_process_env();
  handle_all_queued(ecl_process_env());
  ecl_return0(the_env);
}

void
ecl_check_pending_interrupts(cl_env_ptr env)
{
  if (env->interrupt_struct->pending_interrupt != ECL_NIL)
    handle_all_queued_interrupt_safe(env);
}

static cl_object
do_catch_signal(int code, cl_object action, cl_object process)
{
  if (action == ECL_NIL || action == @':ignore') {
    mysignal(code, SIG_IGN);
    return ECL_T;
  } else if (action == @':default') {
    mysignal(code, SIG_DFL);
    return ECL_T;
  } else if (action == @':mask' || action == @':unmask') {
#ifdef HAVE_SIGPROCMASK
# ifdef ECL_THREADS
    /* When a process object is supplied, the changes take care
     * on the process structure and will only take effect when
     * the process is enabled. */
    if (ecl_t_of(process) == t_process) {
      cl_env_ptr env = process->process.env;
      sigset_t *handled_set = (sigset_t *)env->default_sigmask;
      if (action == @':mask') {
        sigaddset(handled_set, code);
      } else {
        sigdelset(handled_set, code);
      }
      return ECL_T;
    } else {
      sigset_t handled_set;
      pthread_sigmask(SIG_SETMASK, NULL, &handled_set);
      if (action == @':mask') {
        sigaddset(&handled_set, code);
      } else {
        sigdelset(&handled_set, code);
      }
      pthread_sigmask(SIG_SETMASK, &handled_set, NULL);
      return ECL_T;
    }
# else
    {
      sigset_t handled_set;
      sigprocmask(SIG_SETMASK, NULL, &handled_set);
      if (action == @':mask') {
        sigaddset(&handled_set, code);
      } else {
        sigdelset(&handled_set, code);
      }
      sigprocmask(SIG_SETMASK, &handled_set, NULL);
      return ECL_T;
    }
# endif /* !ECL_THREADS */
#else /* !HAVE_SIGPROCMASK */
    return ECL_NIL;
#endif /* !HAVE_SIGPROCMASK */
  } else if (action == ECL_T || action == @':catch') {
    if (code == SIGSEGV) {
      mysignal(code, sigsegv_handler);
    }
#ifdef SIGBUS
    else if (code == SIGBUS) {
      mysignal(code, sigsegv_handler);
    }
#endif
#ifdef SIGILL
    else if (code == SIGILL) {
      mysignal(SIGILL, evil_signal_handler);
    }
#endif
    else {
      mysignal(code, non_evil_signal_handler);
    }
    return ECL_T;
  } else {
    FEerror("Unknown 2nd argument to EXT:CATCH-SIGNAL: ~A", 1,
            action);
  }
}

cl_object
si_get_signal_handler(cl_object code)
{
  const cl_env_ptr the_env = ecl_process_env();
  cl_object handler = ecl_gethash_safe(code, cl_core.known_signals, OBJNULL);
  unlikely_if (handler == OBJNULL) {
    illegal_signal_code(code);
  }
  ecl_return0(the_env);
}

cl_object
si_set_signal_handler(cl_object code, cl_object handler)
{
  const cl_env_ptr the_env = ecl_process_env();
  cl_object action = ecl_gethash_safe(code, cl_core.known_signals, OBJNULL);
  unlikely_if (action == OBJNULL) {
    illegal_signal_code(code);
  }
  ecl_sethash(code, cl_core.known_signals, handler);
  si_catch_signal(2, code, ECL_T);
  ecl_return0(the_env);
}

@(defun ext::catch-signal (code flag &key process)
  @
  {
    const cl_env_ptr the_env = ecl_process_env();
    int code_int;
    unlikely_if (ecl_gethash_safe(code, cl_core.known_signals, OBJNULL) == OBJNULL) {
      illegal_signal_code(code);
    }
    code_int = ecl_fixnum(code);
#ifdef GBC_BOEHM
# ifdef SIGSEGV
    unlikely_if ((code == ecl_make_fixnum(SIGSEGV)) &&
                 ecl_option_values[ECL_OPT_INCREMENTAL_GC])
      FEerror("It is not allowed to change the behavior of SIGSEGV.",
              0);
# endif
# ifdef SIGBUS
    unlikely_if (code_int == SIGBUS)
      FEerror("It is not allowed to change the behavior of SIGBUS.",
              0);
# endif
#endif
#if defined(ECL_THREADS) && !defined(ECL_MS_WINDOWS_HOST)
    unlikely_if (code_int == ecl_option_values[ECL_OPT_THREAD_INTERRUPT_SIGNAL]) {
      FEerror("It is not allowed to change the behavior of signal ~D", 1,
              code);
    }
#endif
#ifdef SIGFPE
    unlikely_if (code_int == SIGFPE) {
      FEerror("The signal handler for SIGPFE cannot be uninstalled. Use SI:TRAP-FPE instead.", 0);
    }
#endif
    ecl_return1(the_env, do_catch_signal(code_int, flag, process));
  }
@)

#ifdef ECL_THREADS
# ifdef ECL_WINDOWS_THREADS
static VOID CALLBACK
wakeup_function(ULONG_PTR foo)
{
  /* Write into the process environment to trigger an exception */
  cl_env_ptr env = ecl_process_env();
  volatile cl_index i = env->nvalues;
  env->nvalues = i;
}

static VOID CALLBACK
wakeup_noop(ULONG_PTR foo)
{
}
# endif

static bool
do_interrupt_thread(cl_object process)
{
# ifdef ECL_WINDOWS_THREADS
#  ifndef ECL_USE_GUARD_PAGE
#   error "Cannot implement ecl_interrupt_process without guard pages"
#  endif
  HANDLE thread = process->process.thread;
  CONTEXT context;
  void *trap_address = process->process.env;
  DWORD guard = PAGE_GUARD | PAGE_READWRITE;
  int ok = 1;
  if (SuspendThread(thread) == (DWORD)-1) {
    FEwin32_error("Unable to suspend thread ~A", 1,
                  process);
    ok = 0;
    goto EXIT;
  }
  process->process.interrupt = ECL_T;
  if (!VirtualProtect(process->process.env,
                      sizeof(struct cl_env_struct),
                      guard,
                      &guard))
    {
      FEwin32_error("Unable to protect memory from thread ~A",
                    1, process);
      ok = 0;
    }
 RESUME:
  if (!QueueUserAPC(wakeup_function, thread, 0)) {
    FEwin32_error("Unable to queue APC call to thread ~A",
                  1, process);
    ok = 0;
  }
  if (ResumeThread(thread) == (DWORD)-1)  {
    FEwin32_error("Unable to resume thread ~A", 1,
                  process);
    ok = 0;
    goto EXIT;
  }
 EXIT:
  return ok;
# else
  int signal = ecl_option_values[ECL_OPT_THREAD_INTERRUPT_SIGNAL];
  if (pthread_kill(process->process.thread, signal)) {
    FElibc_error("Unable to interrupt process ~A", 1,
                 process);
  }
  return 1;
# endif
}

void
ecl_interrupt_process(cl_object process, cl_object function)
{
  /*
   * We first ensure that the process is active and running
   * and past the initialization phase, where it has set up
   * the environment. Then:
   * - In Windows it sets up a trap in the stack, so that the
   *   uncaught exception handler can catch it and process it.
   * - In POSIX systems it sends a user level interrupt to
   *   the thread, which then decides how to act.
   *
   * If FUNCTION is NIL, we just intend to wake up the process
   * from some call to ecl_musleep() Queue the interrupt for any
   * process stage that can potentially receive a signal  */
  if (!Null(function) &&
      (process->process.phase >= ECL_PROCESS_BOOTING))
    {
      cl_env_ptr the_env = ecl_process_env();
      function = si_coerce_to_function(function);
      /* queue_signal must be called with disabled
       * interrupts for the current process */
      ecl_disable_interrupts_env(the_env);
      queue_signal(process->process.env, function, 1);
      ecl_enable_interrupts_env(the_env);
    }
  /* ... but only deliver if the process is still alive */
  if (process->process.phase == ECL_PROCESS_ACTIVE)
    do_interrupt_thread(process);
}

void
ecl_wakeup_process(cl_object process)
{
# ifdef ECL_WINDOWS_THREADS
  HANDLE thread = process->process.thread;
  if (!QueueUserAPC(wakeup_noop, thread, 0)) {
    FEwin32_error("Unable to queue APC call to thread ~A",
                  1, process);
  }
# else
  do_interrupt_thread(process);
# endif
}
#endif /* ECL_THREADS */

#ifdef ECL_WINDOWS_THREADS
static LPTOP_LEVEL_EXCEPTION_FILTER old_W32_exception_filter = NULL;

LONG WINAPI
_ecl_w32_exception_filter(struct _EXCEPTION_POINTERS* ep)
{
  LONG excpt_result;
  cl_env_ptr the_env = ecl_process_env();

  excpt_result = EXCEPTION_CONTINUE_EXECUTION;
  switch (ep->ExceptionRecord->ExceptionCode)
    {
      /* Access to guard page */
    case STATUS_GUARD_PAGE_VIOLATION: {
      cl_object process = the_env->own_process;
      if (!Null(process->process.interrupt)) {
        process->process.interrupt = ECL_NIL;
        handle_all_queued_interrupt_safe(the_env);
      }
      return EXCEPTION_CONTINUE_EXECUTION;
    }
      /* Catch all arithmetic exceptions */
    case EXCEPTION_INT_DIVIDE_BY_ZERO:
      feclearexcept(FE_ALL_EXCEPT);
      handle_signal_now(@'division-by-zero');
      return EXCEPTION_CONTINUE_EXECUTION;
    case EXCEPTION_INT_OVERFLOW:
      feclearexcept(FE_ALL_EXCEPT);
      handle_signal_now(@'arithmetic-error');
      return EXCEPTION_CONTINUE_EXECUTION;
    case EXCEPTION_FLT_DIVIDE_BY_ZERO:
      feclearexcept(FE_ALL_EXCEPT);
      handle_signal_now(@'floating-point-overflow');
      return EXCEPTION_CONTINUE_EXECUTION;
    case EXCEPTION_FLT_OVERFLOW:
      feclearexcept(FE_ALL_EXCEPT);
      handle_signal_now(@'floating-point-overflow');
      return EXCEPTION_CONTINUE_EXECUTION;
    case EXCEPTION_FLT_UNDERFLOW:
      feclearexcept(FE_ALL_EXCEPT);
      handle_signal_now(@'floating-point-underflow');
      return EXCEPTION_CONTINUE_EXECUTION;
    case EXCEPTION_FLT_INEXACT_RESULT:
      feclearexcept(FE_ALL_EXCEPT);
      handle_signal_now(@'floating-point-inexact');
      return EXCEPTION_CONTINUE_EXECUTION;
    case EXCEPTION_FLT_DENORMAL_OPERAND:
    case EXCEPTION_FLT_INVALID_OPERATION:
      feclearexcept(FE_ALL_EXCEPT);
      handle_signal_now(@'floating-point-invalid-operation');
      return EXCEPTION_CONTINUE_EXECUTION;
    case EXCEPTION_FLT_STACK_CHECK:
      handle_signal_now(@'arithmetic-error');
      return EXCEPTION_CONTINUE_EXECUTION;
      /* Catch segmentation fault */
    case EXCEPTION_ACCESS_VIOLATION:
      handle_signal_now(@'ext::segmentation-violation');
      return EXCEPTION_CONTINUE_EXECUTION;
      /* Catch illegal instruction */
    case EXCEPTION_ILLEGAL_INSTRUCTION:
      handle_signal_now(@'ext::illegal-instruction');
      return EXCEPTION_CONTINUE_EXECUTION;
      /* Do not catch anything else */
    default:
      excpt_result = EXCEPTION_CONTINUE_SEARCH;
      break;
    }
  if (old_W32_exception_filter)
    return old_W32_exception_filter(ep);
  return excpt_result;
}

static cl_object
W32_handle_in_new_thread(cl_object signal_code)
{
  int outside_ecl = ecl_import_current_thread(@'si::handle-signal', ECL_NIL);
  mp_process_run_function(3, @'si::handle-signal',
                          @'si::handle-signal',
                          signal_code);
  if (outside_ecl) ecl_release_current_thread();
}

BOOL WINAPI W32_console_ctrl_handler(DWORD type)
{
  switch (type) {
  case CTRL_C_EVENT:
  case CTRL_BREAK_EVENT: {
    cl_object function =
      ECL_SYM_FUN(@'si::terminal-interrupt');
    if (function)
      W32_handle_in_new_thread(function);
    return TRUE;
  }
  case CTRL_CLOSE_EVENT:
  case CTRL_LOGOFF_EVENT:
  case CTRL_SHUTDOWN_EVENT: {
    cl_object function =
      ECL_SYM_FUN(@'ext::quit');
    if (function)
      W32_handle_in_new_thread(function);
    return TRUE;
  }
  default:
    return FALSE;
  }
}
#endif /* ECL_WINDOWS_THREADS */

cl_object
si_trap_fpe(cl_object condition, cl_object flag)
{
  cl_env_ptr the_env = ecl_process_env();
  const int all = FE_ALL_EXCEPT;
  int bits = 0;
  if (condition == @'last') {
    bits = the_env->trap_fpe_bits;
  } else {
    if (condition == ECL_T)
      bits = FE_DIVBYZERO | FE_OVERFLOW | FE_UNDERFLOW | FE_INVALID;
    else if (condition == @'division-by-zero')
      bits = FE_DIVBYZERO;
    else if (condition == @'floating-point-overflow')
      bits = FE_OVERFLOW;
    else if (condition == @'floating-point-underflow')
      bits = FE_UNDERFLOW;
    else if (condition == @'floating-point-invalid-operation')
      bits = FE_INVALID;
    else if (condition == @'floating-point-inexact')
      bits = FE_INEXACT;
    else if (ECL_FIXNUMP(condition))
      bits = ecl_fixnum(condition) & all;
    else
      FEerror("Unknown condition to EXT:TRAP-FPE: ~s", 1, condition);

    if (flag == ECL_NIL) {
      bits = the_env->trap_fpe_bits & ~bits;
    } else {
      bits = the_env->trap_fpe_bits | bits;
    }
  }
#if !defined(ECL_AVOID_FPE_H)
# ifdef HAVE_FENV_H
  feclearexcept(all);
# endif
# if defined(ECL_MS_WINDOWS_HOST)
  _fpreset();
# endif
# ifdef HAVE_FEENABLEEXCEPT
  fedisableexcept(all & ~bits);
  feenableexcept(all & bits);
# endif
#endif
  the_env->trap_fpe_bits = bits;
  ecl_return1(the_env, ecl_make_fixnum(bits));
}

/*
 * In this code we decide whether to install a process-wide signal
 * handler for each of the asynchronous signals (SIGINT, SIGTERM,
 * SIGCHLD...) or we block the signal and let the background thread
 * detect and process them.
 */
static void
install_asynchronous_signal_handlers()
{
#if defined(ECL_MS_WINDOWS_HOST)
# define async_handler(signal,handler,mask)
#else
# if defined(ECL_THREADS) && defined(HAVE_SIGPROCMASK)
#  define async_handler(signal,handler,mask)  {                 \
    if (ecl_option_values[ECL_OPT_SIGNAL_HANDLING_THREAD]) {    \
      mysignal(signal, deferred_signal_handler);                \
    } else {                                                    \
      mysignal(signal,handler);                                 \
    }}
# else
#  define async_handler(signal,handler,mask)    \
  mysignal(signal,handler)
# endif
#endif
#ifdef HAVE_SIGPROCMASK
  sigset_t *sigmask = cl_core.default_sigmask = &main_thread_sigmask;
  cl_core.default_sigmask_bytes = sizeof(sigset_t);
# ifdef ECL_THREADS
  pthread_sigmask(SIG_SETMASK, NULL, sigmask);
# else
  sigprocmask(SIG_SETMASK, NULL, sigmask);
# endif
#endif
#if defined(ECL_THREADS) && defined(HAVE_SIGPROCMASK)
  ecl_mutex_init(&signal_thread_lock, TRUE);
#endif
#ifdef SIGINT
  if (ecl_option_values[ECL_OPT_TRAP_SIGINT]) {
    async_handler(SIGINT, non_evil_signal_handler, sigmask);
  }
#endif
#ifdef HAVE_SIGPROCMASK
# if defined(ECL_THREADS)
  pthread_sigmask(SIG_SETMASK, sigmask, NULL);
# else
  sigprocmask(SIG_SETMASK, sigmask, NULL);
# endif
#endif
#ifdef ECL_WINDOWS_THREADS
  old_W32_exception_filter =
    SetUnhandledExceptionFilter(_ecl_w32_exception_filter);
  if (ecl_option_values[ECL_OPT_TRAP_SIGINT]) {
    SetConsoleCtrlHandler(W32_console_ctrl_handler, TRUE);
  }
#endif
#undef async_handler
}

/*
 * In POSIX systems we may set up a background thread that detects
 * synchronous signals and spawns a new thread to handle each of them.
 */
static void
install_signal_handling_thread()
{
#if defined(ECL_THREADS) && defined(HAVE_SIGPROCMASK)
  ecl_process_env()->default_sigmask = &main_thread_sigmask;
  if (ecl_option_values[ECL_OPT_SIGNAL_HANDLING_THREAD]) {
    cl_object fun =
      ecl_make_cfun((cl_objectfn_fixed)
                    asynchronous_signal_servicing_thread,
                    @'si::signal-servicing',
                    ECL_NIL,
                    0);
    cl_object process =
      signal_thread_process =
      mp_process_run_function_wait(2,
                                   @'si::signal-servicing',
                                   fun);
    if (Null(process)) {
      ecl_internal_error("Unable to create signal "
                         "servicing thread");
    }
  }
#endif
}

/*
 * This routine sets up handlers for all exceptions, such as access to
 * restricted regions of memory. They have to be set up before we call
 * init_GC().
 */
static void
install_synchronous_signal_handlers()
{
#ifdef SIGBUS
  if (ecl_option_values[ECL_OPT_TRAP_SIGBUS]) {
    do_catch_signal(SIGBUS, ECL_T, ECL_NIL);
  }
#endif
#ifdef SIGSEGV
  if (ecl_option_values[ECL_OPT_TRAP_SIGSEGV]) {
    do_catch_signal(SIGSEGV, ECL_T, ECL_NIL);
  }
#endif
#ifdef SIGPIPE
  if (ecl_option_values[ECL_OPT_TRAP_SIGPIPE]) {
    do_catch_signal(SIGPIPE, ECL_T, ECL_NIL);
  }
#endif
#ifdef SIGILL
  if (ecl_option_values[ECL_OPT_TRAP_SIGILL]) {
    do_catch_signal(SIGILL, ECL_T, ECL_NIL);
  }
#endif
  /* In order to implement MP:INTERRUPT-PROCESS, MP:PROCESS-KILL
   * and the like, we use signals. This sets up a synchronous
   * signal handler for that particular signal.
   */
#ifdef SIGRTMIN
# define DEFAULT_THREAD_INTERRUPT_SIGNAL SIGRTMIN + 2
#else
# define DEFAULT_THREAD_INTERRUPT_SIGNAL SIGUSR1
#endif
#if defined(ECL_THREADS) && !defined(ECL_MS_WINDOWS_HOST)
  if (ecl_option_values[ECL_OPT_TRAP_INTERRUPT_SIGNAL]) {
    int signal = ecl_option_values[ECL_OPT_THREAD_INTERRUPT_SIGNAL];
    if (signal == 0) {
      signal = DEFAULT_THREAD_INTERRUPT_SIGNAL;
      ecl_set_option(ECL_OPT_THREAD_INTERRUPT_SIGNAL,
                     signal);
    }
    mysignal(signal, process_interrupt_handler);
#ifdef HAVE_SIGPROCMASK
    sigdelset(&main_thread_sigmask, signal);
    pthread_sigmask(SIG_SETMASK, &main_thread_sigmask, NULL);
#endif
  }
#endif
}

/*
 * This routine sets up handlers for floating point exceptions. We
 * cannot do it earlier because it requires the memory allocator to
 * be set up.
 */
static void
install_fpe_signal_handlers()
{
#ifdef SIGFPE
  if (ecl_option_values[ECL_OPT_TRAP_SIGFPE]) {
    mysignal(SIGFPE, fpe_signal_handler);
    si_trap_fpe(ECL_T, ECL_T);

    /* Don't trap underflows */
    si_trap_fpe(@'floating-point-underflow', ECL_NIL);

# if 0 && defined(ECL_IEEE_FP)
    /* By default deactivate errors and accept denormals
     * in floating point computations. */
    si_trap_fpe(@'floating-point-invalid-operation', ECL_NIL);
    si_trap_fpe(@'division-by-zero', ECL_NIL);
    si_trap_fpe(@'floating-point-overflow', ECL_NIL);
# endif
  }
#endif
}

/*
 * Create one Common Lisp constant for each signal that we know,
 * such as +SIGINT+ for SIGINT, etc.
 */
static void
add_one_signal(cl_object hash_table, int signal, cl_object name, cl_object handler)
{
  cl_object code = ecl_make_fixnum(signal);
  cl_export2(name, cl_core.ext_package);
  si_Xmake_constant(name, code);
  ecl_sethash(code, hash_table, handler);
}

static void
create_signal_code_constants()
{
  cl_object hash =
    cl_core.known_signals =
    cl__make_hash_table(@'eql', ecl_make_fixnum(128),
                        cl_core.rehash_size,
                        cl_core.rehash_threshold);
  int i;
  for (i = 0; known_signals[i].code >= 0; i++) {
    add_one_signal(hash, known_signals[i].code,
                   _ecl_intern(known_signals[i].name,
                               cl_core.ext_package),
                   known_signals[i].handler);
  }
#ifdef SIGRTMIN
  for (i = SIGRTMIN; i <= SIGRTMAX; i++) {
    int intern_flag[1];
    char buffer[64];
    cl_object name;
    sprintf(buffer, "+SIGRT%d+", i-SIGRTMIN);
    name = ecl_intern(ecl_make_simple_base_string(buffer,-1),
                      cl_core.ext_package,
                      intern_flag);
    add_one_signal(hash, i, name, ECL_NIL);
  }
  add_one_signal(hash, SIGRTMIN,
                 _ecl_intern("+SIGRTMIN+", cl_core.ext_package),
                 ECL_NIL);
  add_one_signal(hash, SIGRTMAX,
                 _ecl_intern("+SIGRTMAX+", cl_core.ext_package),
                 ECL_NIL);
#endif
}

void
init_unixint(int pass)
{
  if (pass == 0) {
    install_asynchronous_signal_handlers();
    install_synchronous_signal_handlers();
  } else {
    create_signal_code_constants();
    install_fpe_signal_handlers();
    install_signal_handling_thread();
    ECL_SET(@'ext::*interrupts-enabled*', ECL_T);
    ecl_process_env()->disable_interrupts = 0;
  }
}
