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 ;;; These should probably be somewhere, but I don't know where.
  15 (defconstant sig_dfl 0)
  16 (defconstant sig_ign 1)
  17 \f
  18 ;;;; system calls that deal with signals
  19
  20 ;;; Send the signal SIGNAL to the process with process id PID. SIGNAL
  21 ;;; should be a valid signal number
  22 #!-sb-fluid (declaim (inline real-unix-kill))
  23 (sb!alien:define-alien-routine ("kill" unix-kill) sb!alien:int
  24   (pid sb!alien:int)
  25   (signal sb!alien:int))
  26
  27 ;;; Send the signal SIGNAL to the all the process in process group
  28 ;;; PGRP. SIGNAL should be a valid signal number
  29 #!-sb-fluid (declaim (inline real-unix-killpg))
  30 (sb!alien:define-alien-routine ("killpg" unix-killpg) sb!alien:int
  31   (pgrp sb!alien:int)
  32   (signal sb!alien:int))
  33
  34 ;;; Reset the current set of masked signals (those being blocked from
  35 ;;; delivery).
  36 ;;;
  37 ;;; (Note: CMU CL had a more general SIGSETMASK call and a SIGMASK
  38 ;;; operator to create masks, but since we only ever reset to 0, we no
  39 ;;; longer support it. If you need it, you can pull it out of the CMU
  40 ;;; CL sources, or the old SBCL sources; but you might also consider
  41 ;;; doing things the SBCL way and moving this kind of C-level work
  42 ;;; down to C wrapper functions.)
  43
  44 ;;; When inappropriate build options are used, this also prints messages
  45 ;;; listing the signals that were masked
  46 (sb!alien:define-alien-routine "reset_signal_mask" sb!alien:void)
  47 \f
  48 ;;;; C routines that actually do all the work of establishing signal handlers
  49 (sb!alien:define-alien-routine ("install_handler" install-handler)
  50                                sb!alien:unsigned-long
  51   (signal sb!alien:int)
  52   (handler sb!alien:unsigned-long))
  53
  54 ;;;; interface to enabling and disabling signal handlers
  55
  56 (defun enable-interrupt (signal handler)
  57   (declare (type (or function fixnum (member :default :ignore)) handler))
  58   (/show0 "enable-interrupt")
  59   (without-gcing
  60    (let ((result (install-handler signal
  61                                   (case handler
  62                                     (:default sig_dfl)
  63                                     (:ignore sig_ign)
  64                                     (t
  65                                      (sb!kernel:get-lisp-obj-address
  66                                       handler))))))
  67      (cond ((= result sig_dfl) :default)
  68            ((= result sig_ign) :ignore)
  69            (t (the (or function fixnum) (sb!kernel:make-lisp-obj result)))))))
  70
  71 (defun default-interrupt (signal)
  72   (enable-interrupt signal :default))
  73
  74 (defun ignore-interrupt (signal)
  75   (enable-interrupt signal :ignore))
  76 \f
  77 ;;;; default LISP signal handlers
  78 ;;;;
  79 ;;;; Most of these just call ERROR to report the presence of the signal.
  80
  81 ;;; SIGINT is handled like BREAK, except that ANSI BREAK ignores
  82 ;;; *DEBUGGER-HOOK*, but we want SIGINT's BREAK to respect it, so that
  83 ;;; SIGINT in --disable-debugger mode will cleanly terminate the system
  84 ;;; (by respecting the *DEBUGGER-HOOK* established in that mode).
  85 (defun sigint-%break (format-string &rest format-arguments)
  86   #!+sb-thread
  87   (let ((foreground-thread (sb!thread::foreground-thread)))
  88     (if (eql foreground-thread (sb!thread:current-thread-id))
  89         (apply #'%break 'sigint format-string format-arguments)
  90         (sb!thread:interrupt-thread
  91          foreground-thread
  92          (lambda () (apply #'%break 'sigint format-string format-arguments)))))
  93   #!-sb-thread
  94   (apply #'%break 'sigint format-string format-arguments))
  95
  96 (eval-when (:compile-toplevel :execute)
  97   (sb!xc:defmacro define-signal-handler (name
  98                                          what
  99                                          &optional (function 'error))
 100     `(defun ,name (signal info context)
 101        (declare (ignore signal info))
 102        (declare (type system-area-pointer context))
 103        (/show "in Lisp-level signal handler" ,(symbol-name name) (sap-int context))
 104        (,function ,(concatenate 'simple-string what " at #X~X")
 105                   (with-alien ((context (* os-context-t) context))
 106                     (sap-int (sb!vm:context-pc context)))))))
 107
 108 (define-signal-handler sigint-handler "interrupted" sigint-%break)
 109 (define-signal-handler sigill-handler "illegal instruction")
 110 (define-signal-handler sigtrap-handler "breakpoint/trap")
 111 (define-signal-handler sigiot-handler "SIGIOT")
 112 #!-linux
 113 (define-signal-handler sigemt-handler "SIGEMT")
 114 (define-signal-handler sigbus-handler "bus error")
 115 (define-signal-handler sigsegv-handler "segmentation violation")
 116 #!-linux
 117 (define-signal-handler sigsys-handler "bad argument to a system call")
 118 (define-signal-handler sigpipe-handler "SIGPIPE")
 119
 120 (defun sigalrm-handler (signal info context)
 121   (declare (ignore signal info context))
 122   (declare (type system-area-pointer context))
 123   (cerror "Continue" 'sb!ext::timeout))
 124
 125 (defun sigquit-handler (signal code context)
 126   (declare (ignore signal code context))
 127   (throw 'toplevel-catcher nil))
 128
 129 (defun sb!kernel:signal-cold-init-or-reinit ()
 130   #!+sb-doc
 131   "Enable all the default signals that Lisp knows how to deal with."
 132   (enable-interrupt sigint #'sigint-handler)
 133   (enable-interrupt sigquit #'sigquit-handler)
 134   (enable-interrupt sigill #'sigill-handler)
 135   (enable-interrupt sigtrap #'sigtrap-handler)
 136   (enable-interrupt sigiot #'sigiot-handler)
 137   #!-linux
 138   (enable-interrupt sigemt #'sigemt-handler)
 139   (enable-interrupt sigfpe #'sb!vm:sigfpe-handler)
 140   (enable-interrupt sigbus #'sigbus-handler)
 141   (enable-interrupt sigsegv #'sigsegv-handler)
 142   #!-linux
 143   (enable-interrupt sigsys #'sigsys-handler)
 144   (enable-interrupt sigpipe #'sigpipe-handler)
 145   (enable-interrupt sigalrm #'sigalrm-handler)
 146   (values))
 147 \f
 148 ;;;; etc.
 149
 150 ;;; CMU CL comment:
 151 ;;;   Magically converted by the compiler into a break instruction.
 152 (defun receive-pending-interrupt ()
 153   (receive-pending-interrupt))
 154 \f
 155 ;;; stale code which I'm insufficiently motivated to test -- WHN 19990714
 156 #|
 157 ;;;; WITH-ENABLED-INTERRUPTS
 158
 159 (defmacro with-enabled-interrupts (interrupt-list &body body)
 160   #!+sb-doc
 161   "With-enabled-interrupts ({(interrupt function)}*) {form}*
 162    Establish function as a handler for the Unix signal interrupt which
 163    should be a number between 1 and 31 inclusive."
 164   (let ((il (gensym))
 165         (it (gensym)))
 166     `(let ((,il NIL))
 167        (unwind-protect
 168            (progn
 169              ,@(do* ((item interrupt-list (cdr item))
 170                      (intr (caar item) (caar item))
 171                      (ifcn (cadar item) (cadar item))
 172                      (forms NIL))
 173                     ((null item) (nreverse forms))
 174                  (when (symbolp intr)
 175                    (setq intr (symbol-value intr)))
 176                  (push `(push `(,,intr ,(enable-interrupt ,intr ,ifcn)) ,il)
 177                        forms))
 178              ,@body)
 179          (dolist (,it (nreverse ,il))
 180            (enable-interrupt (car ,it) (cadr ,it)))))))
 181 |#