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))
 187 \f
 188 ;;; stale code which I'm insufficiently motivated to test -- WHN 19990714
 189 #|
 190 ;;;; WITH-ENABLED-INTERRUPTS
 191
 192 (defmacro with-enabled-interrupts (interrupt-list &body body)
 193   #!+sb-doc
 194   "With-enabled-interrupts ({(interrupt function)}*) {form}*
 195    Establish function as a handler for the Unix signal interrupt which
 196    should be a number between 1 and 31 inclusive."
 197   (let ((il (gensym))
 198         (it (gensym)))
 199     `(let ((,il NIL))
 200        (unwind-protect
 201            (progn
 202              ,@(do* ((item interrupt-list (cdr item))
 203                      (intr (caar item) (caar item))
 204                      (ifcn (cadar item) (cadar item))
 205                      (forms NIL))
 206                     ((null item) (nreverse forms))
 207                  (when (symbolp intr)
 208                    (setq intr (symbol-value intr)))
 209                  (push `(push `(,,intr ,(enable-interrupt ,intr ,ifcn)) ,il)
 210                        forms))
 211              ,@body)
 212          (dolist (,it (nreverse ,il))
 213            (enable-interrupt (car ,it) (cadr ,it)))))))
 214 |#