src/code/target-signal.lisp

   1 ;;;; code for handling UNIX signals
   2
   3 ;;;; This software is part of the SBCL system. See the README file for
   4 ;;;; more information.
   5 ;;;;
   6 ;;;; This software is derived from the CMU CL system, which was
   7 ;;;; written at Carnegie Mellon University and released into the
   8 ;;;; public domain. The software is in the public domain and is
   9 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
  10 ;;;; files for more information.
  11
  12 (in-package "SB!UNIX")
  13
  14 (defun invoke-interruption (function)
  15   (without-interrupts
  16     ;; FIXME: This is wrong. Imagine the following sequence:
  17     ;;
  18     ;; 1. an asynch interrupt arrives after entry to
  19     ;;    WITHOUT-INTERRUPTS but before RESET-SIGNAL-MASK: pending
  20     ;;    machinery blocks all signals and marks the signal as
  21     ;;    pending.
  22     ;;
  23     ;; 2. RESET-SIGNAL-MASK is called, and all signals are unblocked.
  24     ;;
  25     ;; 3. Another signal arrives while we already have one pending.
  26     ;;    Oops -- we lose().
  27     ;;
  28     ;; Not sure what the right thing is, but definitely not
  29     ;; RESET-SIGNAL-MASK. Removing it breaks signals.impure.lisp
  30     ;; right now, though, and this is a rare race, so...
  31     (reset-signal-mask)
  32     (funcall function)))
  33
  34 (defmacro in-interruption ((&rest args) &body body)
  35   #!+sb-doc
  36   "Convenience macro on top of INVOKE-INTERRUPTION."
  37   `(invoke-interruption (lambda () ,@body) ,@args))
  38 \f
  39 ;;;; system calls that deal with signals
  40
  41 ;;; Send the signal SIGNAL to the process with process id PID. SIGNAL
  42 ;;; should be a valid signal number
  43 #!-sb-fluid (declaim (inline real-unix-kill))
  44 (sb!alien:define-alien-routine ("kill" unix-kill) sb!alien:int
  45   (pid sb!alien:int)
  46   (signal sb!alien:int))
  47
  48 ;;; Send the signal SIGNAL to the all the process in process group
  49 ;;; PGRP. SIGNAL should be a valid signal number
  50 #!-sb-fluid (declaim (inline real-unix-killpg))
  51 (sb!alien:define-alien-routine ("killpg" unix-killpg) sb!alien:int
  52   (pgrp sb!alien:int)
  53   (signal sb!alien:int))
  54
  55 ;;; Reset the current set of masked signals (those being blocked from
  56 ;;; delivery).
  57 ;;;
  58 ;;; (Note: CMU CL had a more general SIGSETMASK call and a SIGMASK
  59 ;;; operator to create masks, but since we only ever reset to 0, we no
  60 ;;; longer support it. If you need it, you can pull it out of the CMU
  61 ;;; CL sources, or the old SBCL sources; but you might also consider
  62 ;;; doing things the SBCL way and moving this kind of C-level work
  63 ;;; down to C wrapper functions.)
  64
  65 ;;; When inappropriate build options are used, this also prints messages
  66 ;;; listing the signals that were masked
  67 (sb!alien:define-alien-routine "reset_signal_mask" sb!alien:void)
  68
  69 \f
  70 ;;;; C routines that actually do all the work of establishing signal handlers
  71 (sb!alien:define-alien-routine ("install_handler" install-handler)
  72                                sb!alien:unsigned-long
  73   (signal sb!alien:int)
  74   (handler sb!alien:unsigned-long))
  75
  76 ;;;; interface to enabling and disabling signal handlers
  77
  78 (defun enable-interrupt (signal handler)
  79   (declare (type (or function fixnum (member :default :ignore)) handler))
  80   (/show0 "enable-interrupt")
  81   (flet ((run-handler (&rest args)
  82            (in-interruption ()
  83              (apply handler args))))
  84     (without-gcing
  85       (let ((result (install-handler signal
  86                                      (case handler
  87                                        (:default sig-dfl)
  88                                        (:ignore sig-ign)
  89                                        (t
  90                                         (sb!kernel:get-lisp-obj-address
  91                                          #'run-handler))))))
  92         (cond ((= result sig-dfl) :default)
  93               ((= result sig-ign) :ignore)
  94               (t (the (or function fixnum)
  95                    (sb!kernel:make-lisp-obj result))))))))
  96
  97 (defun default-interrupt (signal)
  98   (enable-interrupt signal :default))
  99
 100 (defun ignore-interrupt (signal)
 101   (enable-interrupt signal :ignore))
 102 \f
 103 ;;;; default LISP signal handlers
 104 ;;;;
 105 ;;;; Most of these just call ERROR to report the presence of the signal.
 106
 107 ;;; SIGINT is handled like BREAK, except that ANSI BREAK ignores
 108 ;;; *DEBUGGER-HOOK*, but we want SIGINT's BREAK to respect it, so that
 109 ;;; SIGINT in --disable-debugger mode will cleanly terminate the system
 110 ;;; (by respecting the *DEBUGGER-HOOK* established in that mode).
 111 (eval-when (:compile-toplevel :execute)
 112   (sb!xc:defmacro define-signal-handler (name what &optional (function 'error))
 113     `(defun ,name (signal info context)
 114        (declare (ignore signal info))
 115        (declare (type system-area-pointer context))
 116        (/show "in Lisp-level signal handler" ,(symbol-name name)
 117               (sap-int context))
 118        (with-interrupts
 119          (,function ,(concatenate 'simple-string what " at #X~X")
 120                     (with-alien ((context (* os-context-t) context))
 121                       (sap-int (sb!vm:context-pc context))))))))
 122
 123 (define-signal-handler sigill-handler "illegal instruction")
 124 #!-linux
 125 (define-signal-handler sigemt-handler "SIGEMT")
 126 (define-signal-handler sigbus-handler "bus error")
 127 (define-signal-handler sigsegv-handler "segmentation violation")
 128 #!-linux
 129 (define-signal-handler sigsys-handler "bad argument to a system call")
 130
 131 (defun sigint-handler (signal info context)
 132   (declare (ignore signal info))
 133   (declare (type system-area-pointer context))
 134   (/show "in Lisp-level SIGINT handler" (sap-int context))
 135   (flet ((interrupt-it ()
 136            (with-alien ((context (* os-context-t) context))
 137              (%break 'sigint 'interactive-interrupt
 138                      :context context
 139                      :address (sap-int (sb!vm:context-pc context))))))
 140     (sb!thread:interrupt-thread (sb!thread::foreground-thread)
 141                                 #'interrupt-it)))
 142
 143 (defun sigalrm-handler (signal info context)
 144   (declare (ignore signal info context))
 145   (declare (type system-area-pointer context))
 146   (sb!impl::run-expired-timers))
 147
 148 (defun sigterm-handler (signal code context)
 149   (declare (ignore signal code context))
 150   (sb!thread::terminate-session)
 151   (sb!ext:quit))
 152
 153 ;; Also known as SIGABRT.
 154 (defun sigiot-handler (signal code context)
 155   (declare (ignore signal code context))
 156   (sb!impl::%halt))
 157
 158 (defun sb!kernel:signal-cold-init-or-reinit ()
 159   #!+sb-doc
 160   "Enable all the default signals that Lisp knows how to deal with."
 161   (enable-interrupt sigint #'sigint-handler)
 162   (enable-interrupt sigterm #'sigterm-handler)
 163   (enable-interrupt sigill #'sigill-handler)
 164   (enable-interrupt sigiot #'sigiot-handler)
 165   #!-linux
 166   (enable-interrupt sigemt #'sigemt-handler)
 167   (enable-interrupt sigfpe #'sb!vm:sigfpe-handler)
 168   (enable-interrupt sigbus #'sigbus-handler)
 169   (enable-interrupt sigsegv #'sigsegv-handler)
 170   #!-linux
 171   (enable-interrupt sigsys #'sigsys-handler)
 172   (ignore-interrupt sigpipe)
 173   (enable-interrupt sigalrm #'sigalrm-handler)
 174   (sb!unix::reset-signal-mask)
 175   (values))
 176 \f
 177 ;;;; etc.
 178
 179 ;;; extract si_code from siginfo_t
 180 (sb!alien:define-alien-routine ("siginfo_code" siginfo-code) sb!alien:int
 181   (info system-area-pointer))
 182
 183 ;;; CMU CL comment:
 184 ;;;   Magically converted by the compiler into a break instruction.
 185 (defun receive-pending-interrupt ()
 186   (receive-pending-interrupt))