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