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