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   (with-unique-names (empty)
  16     `(let*
  17          ;; KLUDGE: Whatever is on the PCL stacks before the interrupt
  18          ;; handler runs doesn't really matter, since we're not on the
  19          ;; same call stack, really -- and if we don't bind these (esp.
  20          ;; the cache one) we can get a bogus metacircle if an interrupt
  21          ;; handler calls a GF that was being computed when the interrupt
  22          ;; hit.
  23          ((sb!pcl::*cache-miss-values-stack* nil)
  24           (sb!pcl::*dfun-miss-gfs-on-stack* nil)
  25           ;; Unless we do this, ADJUST-ARRAY and SORT would need to
  26           ;; disable interrupts.
  27           (,empty (vector))
  28           (sb!impl::*zap-array-data-temp* ,empty)
  29           (sb!impl::*merge-sort-temp-vector* ,empty))
  30        ,@body)))
  31
  32 ;;; Evaluate CLEANUP-FORMS iff PROTECTED-FORM does a non-local exit.
  33 (defmacro nlx-protect (protected-form &rest cleanup-froms)
  34   (with-unique-names (completep)
  35     `(let ((,completep nil))
  36        (without-interrupts
  37          (unwind-protect
  38               (progn
  39                 (allow-with-interrupts
  40                   ,protected-form)
  41                 (setq ,completep t))
  42            (unless ,completep
  43              ,@cleanup-froms))))))
  44
  45 (defun invoke-interruption (function)
  46   (without-interrupts
  47     ;; Reset signal mask: the C-side handler has blocked all
  48     ;; deferrable signals before funcalling into lisp. They are to be
  49     ;; unblocked the first time interrupts are enabled. With this
  50     ;; mechanism there are no extra frames on the stack from a
  51     ;; previous signal handler when the next signal is delivered
  52     ;; provided there is no WITH-INTERRUPTS.
  53     (let ((*unblock-deferrables-on-enabling-interrupts-p* t))
  54       (with-interrupt-bindings
  55         (let ((sb!debug:*stack-top-hint*
  56                (nth-value 1 (sb!kernel:find-interrupted-name-and-frame))))
  57           (allow-with-interrupts
  58             (nlx-protect (funcall function)
  59                          ;; We've been running with deferrables
  60                          ;; blocked in Lisp called by a C signal
  61                          ;; handler. If we return normally the sigmask
  62                          ;; in the interrupted context is restored.
  63                          ;; However, if we do an nlx the operating
  64                          ;; system will not restore it for us.
  65                          (when *unblock-deferrables-on-enabling-interrupts-p*
  66                            ;; This means that storms of interrupts
  67                            ;; doing an nlx can still run out of stack.
  68                            (unblock-deferrable-signals)))))))))
  69
  70 (defmacro in-interruption ((&key) &body body)
  71   #!+sb-doc
  72   "Convenience macro on top of INVOKE-INTERRUPTION."
  73   `(dx-flet ((interruption () ,@body))
  74      (invoke-interruption #'interruption)))
  75 \f
  76 ;;;; system calls that deal with signals
  77
  78 ;;; Send the signal SIGNAL to the process with process id PID. SIGNAL
  79 ;;; should be a valid signal number
  80 #!-sb-fluid (declaim (inline real-unix-kill))
  81 (sb!alien:define-alien-routine ("kill" unix-kill) sb!alien:int
  82   (pid sb!alien:int)
  83   (signal sb!alien:int))
  84
  85 ;;; Send the signal SIGNAL to the all the process in process group
  86 ;;; PGRP. SIGNAL should be a valid signal number
  87 #!-sb-fluid (declaim (inline real-unix-killpg))
  88 (sb!alien:define-alien-routine ("killpg" unix-killpg) sb!alien:int
  89   (pgrp sb!alien:int)
  90   (signal sb!alien:int))
  91
  92 ;;; Reset the current set of masked signals (those being blocked from
  93 ;;; delivery).
  94 ;;;
  95 ;;; (Note: CMU CL had a more general SIGSETMASK call and a SIGMASK
  96 ;;; operator to create masks, but since we only ever reset to 0, we no
  97 ;;; longer support it. If you need it, you can pull it out of the CMU
  98 ;;; CL sources, or the old SBCL sources; but you might also consider
  99 ;;; doing things the SBCL way and moving this kind of C-level work
 100 ;;; down to C wrapper functions.)
 101
 102 (sb!alien:define-alien-routine "unblock_deferrable_signals" sb!alien:void)
 103 (sb!alien:define-alien-routine "unblock_gc_signals" sb!alien:void)
 104
 105 \f
 106 ;;;; C routines that actually do all the work of establishing signal handlers
 107 (sb!alien:define-alien-routine ("install_handler" install-handler)
 108                                sb!alien:unsigned-long
 109   (signal sb!alien:int)
 110   (handler sb!alien:unsigned-long))
 111
 112 ;;;; interface to enabling and disabling signal handlers
 113
 114 (defun enable-interrupt (signal handler)
 115   (declare (type (or function fixnum (member :default :ignore)) handler))
 116   (/show0 "enable-interrupt")
 117   (flet ((run-handler (&rest args)
 118            (declare (truly-dynamic-extent args))
 119            (in-interruption ()
 120              (apply handler args))))
 121     (without-gcing
 122       (let ((result (install-handler signal
 123                                      (case handler
 124                                        (:default sig-dfl)
 125                                        (:ignore sig-ign)
 126                                        (t
 127                                         (sb!kernel:get-lisp-obj-address
 128                                          #'run-handler))))))
 129         (cond ((= result sig-dfl) :default)
 130               ((= result sig-ign) :ignore)
 131               (t (the (or function fixnum)
 132                    (sb!kernel:make-lisp-obj result))))))))
 133
 134 (defun default-interrupt (signal)
 135   (enable-interrupt signal :default))
 136
 137 (defun ignore-interrupt (signal)
 138   (enable-interrupt signal :ignore))
 139 \f
 140 ;;;; default LISP signal handlers
 141 ;;;;
 142 ;;;; Most of these just call ERROR to report the presence of the signal.
 143
 144 ;;; SIGINT is handled like BREAK, except that ANSI BREAK ignores
 145 ;;; *DEBUGGER-HOOK*, but we want SIGINT's BREAK to respect it, so that
 146 ;;; SIGINT in --disable-debugger mode will cleanly terminate the system
 147 ;;; (by respecting the *DEBUGGER-HOOK* established in that mode).
 148 (eval-when (:compile-toplevel :execute)
 149   (sb!xc:defmacro define-signal-handler (name what &optional (function 'error))
 150     `(defun ,name (signal info context)
 151        (declare (ignore signal info))
 152        (declare (type system-area-pointer context))
 153        (/show "in Lisp-level signal handler" ,(symbol-name name)
 154               (sap-int context))
 155        (with-interrupts
 156          (,function ,(concatenate 'simple-string what " at #X~X")
 157                     (with-alien ((context (* os-context-t) context))
 158                       (sap-int (sb!vm:context-pc context))))))))
 159
 160 (define-signal-handler sigill-handler "illegal instruction")
 161 #!-linux
 162 (define-signal-handler sigemt-handler "SIGEMT")
 163 (define-signal-handler sigbus-handler "bus error")
 164 (define-signal-handler sigsegv-handler "segmentation violation")
 165 #!-linux
 166 (define-signal-handler sigsys-handler "bad argument to a system call")
 167
 168 (defun sigint-handler (signal info context)
 169   (declare (ignore signal info))
 170   (declare (type system-area-pointer context))
 171   (/show "in Lisp-level SIGINT handler" (sap-int context))
 172   (flet ((interrupt-it ()
 173            (with-alien ((context (* os-context-t) context))
 174              (with-interrupts
 175                (%break 'sigint 'interactive-interrupt
 176                        :context context
 177                        :address (sap-int (sb!vm:context-pc context)))))))
 178     (sb!thread:interrupt-thread (sb!thread::foreground-thread)
 179                                 #'interrupt-it)))
 180
 181 (defun sigalrm-handler (signal info context)
 182   (declare (ignore signal info context))
 183   (declare (type system-area-pointer context))
 184   (sb!impl::run-expired-timers))
 185
 186 (defun sigterm-handler (signal code context)
 187   (declare (ignore signal code context))
 188   (sb!thread::terminate-session)
 189   (sb!ext:quit))
 190
 191 ;;; SIGPIPE is not used in SBCL for its original purpose, instead it's
 192 ;;; for signalling a thread that it should look at its interruption
 193 ;;; queue. The handler (RUN_INTERRUPTION) just returns if there is
 194 ;;; nothing to do so it's safe to receive spurious SIGPIPEs coming
 195 ;;; from the kernel.
 196 (defun sigpipe-handler (signal code context)
 197   (declare (ignore signal code context))
 198   (sb!thread::run-interruption))
 199
 200 (defun sb!kernel:signal-cold-init-or-reinit ()
 201   #!+sb-doc
 202   "Enable all the default signals that Lisp knows how to deal with."
 203   (enable-interrupt sigint #'sigint-handler)
 204   (enable-interrupt sigterm #'sigterm-handler)
 205   (enable-interrupt sigill #'sigill-handler)
 206   #!-linux
 207   (enable-interrupt sigemt #'sigemt-handler)
 208   (enable-interrupt sigfpe #'sb!vm:sigfpe-handler)
 209   (enable-interrupt sigbus #'sigbus-handler)
 210   (enable-interrupt sigsegv #'sigsegv-handler)
 211   #!-linux
 212   (enable-interrupt sigsys #'sigsys-handler)
 213   (enable-interrupt sigalrm #'sigalrm-handler)
 214   (enable-interrupt sigpipe #'sigpipe-handler)
 215   #!+hpux (ignore-interrupt sigxcpu)
 216   (unblock-gc-signals)
 217   (unblock-deferrable-signals)
 218   (values))
 219 \f
 220 ;;;; etc.
 221
 222 ;;; extract si_code from siginfo_t
 223 (sb!alien:define-alien-routine ("siginfo_code" siginfo-code) sb!alien:int
 224   (info system-area-pointer))
 225
 226 ;;; CMU CL comment:
 227 ;;;   Magically converted by the compiler into a break instruction.
 228 (defun receive-pending-interrupt ()
 229   (receive-pending-interrupt))