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 (defmacro with-interrupt-bindings (&body body)
  15   `(let
  16       ;; KLUDGE: Whatever is on the PCL stacks before the interrupt
  17       ;; handler runs doesn't really matter, since we're not on the
  18       ;; same call stack, really -- and if we don't bind these (esp.
  19       ;; the cache one) we can get a bogus metacircle if an interrupt
  20       ;; handler calls a GF that was being computed when the interrupt
  21       ;; hit.
  22       ((sb!pcl::*cache-miss-values-stack* nil)
  23        (sb!pcl::*dfun-miss-gfs-on-stack* nil))
  24      ,@body))
  25
  26 (defun invoke-interruption (function)
  27   (with-interrupt-bindings
  28     (without-interrupts
  29       ;; Reset signal mask: the C-side handler has blocked all
  30       ;; deferrable interrupts before arranging return to lisp. This is
  31       ;; safe because we can't get a pending interrupt before we unblock
  32       ;; signals.
  33       ;;
  34       ;; FIXME: Should we not reset the _entire_ mask, but just
  35       ;; restore it to the state before we got the interrupt?
  36       (reset-signal-mask)
  37       (allow-with-interrupts (funcall function)))))
  38
  39 (defmacro in-interruption ((&key) &body body)
  40   #!+sb-doc
  41   "Convenience macro on top of INVOKE-INTERRUPTION."
  42   `(dx-flet ((interruption () ,@body))
  43      (invoke-interruption #'interruption)))
  44 \f
  45 ;;;; system calls that deal with signals
  46
  47 ;;; Send the signal SIGNAL to the process with process id PID. SIGNAL
  48 ;;; should be a valid signal number
  49 #!-sb-fluid (declaim (inline real-unix-kill))
  50 (sb!alien:define-alien-routine ("kill" unix-kill) sb!alien:int
  51   (pid sb!alien:int)
  52   (signal sb!alien:int))
  53
  54 ;;; Send the signal SIGNAL to the all the process in process group
  55 ;;; PGRP. SIGNAL should be a valid signal number
  56 #!-sb-fluid (declaim (inline real-unix-killpg))
  57 (sb!alien:define-alien-routine ("killpg" unix-killpg) sb!alien:int
  58   (pgrp sb!alien:int)
  59   (signal sb!alien:int))
  60
  61 ;;; Reset the current set of masked signals (those being blocked from
  62 ;;; delivery).
  63 ;;;
  64 ;;; (Note: CMU CL had a more general SIGSETMASK call and a SIGMASK
  65 ;;; operator to create masks, but since we only ever reset to 0, we no
  66 ;;; longer support it. If you need it, you can pull it out of the CMU
  67 ;;; CL sources, or the old SBCL sources; but you might also consider
  68 ;;; doing things the SBCL way and moving this kind of C-level work
  69 ;;; down to C wrapper functions.)
  70
  71 ;;; When inappropriate build options are used, this also prints messages
  72 ;;; listing the signals that were masked
  73 (sb!alien:define-alien-routine "reset_signal_mask" sb!alien:void)
  74
  75 \f
  76 ;;;; C routines that actually do all the work of establishing signal handlers
  77 (sb!alien:define-alien-routine ("install_handler" install-handler)
  78                                sb!alien:unsigned-long
  79   (signal sb!alien:int)
  80   (handler sb!alien:unsigned-long))
  81
  82 ;;;; interface to enabling and disabling signal handlers
  83
  84 (defun enable-interrupt (signal handler)
  85   (declare (type (or function fixnum (member :default :ignore)) handler))
  86   (/show0 "enable-interrupt")
  87   (flet ((run-handler (&rest args)
  88            (in-interruption ()
  89              (apply handler args))))
  90     (without-gcing
  91       (let ((result (install-handler signal
  92                                      (case handler
  93                                        (:default sig-dfl)
  94                                        (:ignore sig-ign)
  95                                        (t
  96                                         (sb!kernel:get-lisp-obj-address
  97                                          #'run-handler))))))
  98         (cond ((= result sig-dfl) :default)
  99               ((= result sig-ign) :ignore)
 100               (t (the (or function fixnum)
 101                    (sb!kernel:make-lisp-obj result))))))))
 102
 103 (defun default-interrupt (signal)
 104   (enable-interrupt signal :default))
 105
 106 (defun ignore-interrupt (signal)
 107   (enable-interrupt signal :ignore))
 108 \f
 109 ;;;; default LISP signal handlers
 110 ;;;;
 111 ;;;; Most of these just call ERROR to report the presence of the signal.
 112
 113 ;;; SIGINT is handled like BREAK, except that ANSI BREAK ignores
 114 ;;; *DEBUGGER-HOOK*, but we want SIGINT's BREAK to respect it, so that
 115 ;;; SIGINT in --disable-debugger mode will cleanly terminate the system
 116 ;;; (by respecting the *DEBUGGER-HOOK* established in that mode).
 117 (eval-when (:compile-toplevel :execute)
 118   (sb!xc:defmacro define-signal-handler (name what &optional (function 'error))
 119     `(defun ,name (signal info context)
 120        (declare (ignore signal info))
 121        (declare (type system-area-pointer context))
 122        (/show "in Lisp-level signal handler" ,(symbol-name name)
 123               (sap-int context))
 124        (with-interrupts
 125          (,function ,(concatenate 'simple-string what " at #X~X")
 126                     (with-alien ((context (* os-context-t) context))
 127                       (sap-int (sb!vm:context-pc context))))))))
 128
 129 (define-signal-handler sigill-handler "illegal instruction")
 130 #!-linux
 131 (define-signal-handler sigemt-handler "SIGEMT")
 132 (define-signal-handler sigbus-handler "bus error")
 133 (define-signal-handler sigsegv-handler "segmentation violation")
 134 #!-linux
 135 (define-signal-handler sigsys-handler "bad argument to a system call")
 136
 137 (defun sigint-handler (signal info context)
 138   (declare (ignore signal info))
 139   (declare (type system-area-pointer context))
 140   (/show "in Lisp-level SIGINT handler" (sap-int context))
 141   (flet ((interrupt-it ()
 142            (with-alien ((context (* os-context-t) context))
 143              (%break 'sigint 'interactive-interrupt
 144                      :context context
 145                      :address (sap-int (sb!vm:context-pc context))))))
 146     (sb!thread:interrupt-thread (sb!thread::foreground-thread)
 147                                 #'interrupt-it)))
 148
 149 (defun sigalrm-handler (signal info context)
 150   (declare (ignore signal info context))
 151   (declare (type system-area-pointer context))
 152   (sb!impl::run-expired-timers))
 153
 154 (defun sigterm-handler (signal code context)
 155   (declare (ignore signal code context))
 156   (sb!thread::terminate-session)
 157   (sb!ext:quit))
 158
 159 ;; Also known as SIGABRT.
 160 (defun sigiot-handler (signal code context)
 161   (declare (ignore signal code context))
 162   (sb!impl::%halt))
 163
 164 (defun sb!kernel:signal-cold-init-or-reinit ()
 165   #!+sb-doc
 166   "Enable all the default signals that Lisp knows how to deal with."
 167   (enable-interrupt sigint #'sigint-handler)
 168   (enable-interrupt sigterm #'sigterm-handler)
 169   (enable-interrupt sigill #'sigill-handler)
 170   (enable-interrupt sigiot #'sigiot-handler)
 171   #!-linux
 172   (enable-interrupt sigemt #'sigemt-handler)
 173   (enable-interrupt sigfpe #'sb!vm:sigfpe-handler)
 174   (enable-interrupt sigbus #'sigbus-handler)
 175   (enable-interrupt sigsegv #'sigsegv-handler)
 176   #!-linux
 177   (enable-interrupt sigsys #'sigsys-handler)
 178   (ignore-interrupt sigpipe)
 179   (enable-interrupt sigalrm #'sigalrm-handler)
 180   (sb!unix::reset-signal-mask)
 181   (values))
 182 \f
 183 ;;;; etc.
 184
 185 ;;; extract si_code from siginfo_t
 186 (sb!alien:define-alien-routine ("siginfo_code" siginfo-code) sb!alien:int
 187   (info system-area-pointer))
 188
 189 ;;; CMU CL comment:
 190 ;;;   Magically converted by the compiler into a break instruction.
 191 (defun receive-pending-interrupt ()
 192   (receive-pending-interrupt))