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 #!-sb-fluid (declaim (inline real-unix-kill))
  21 (sb!alien:def-alien-routine ("kill" real-unix-kill) sb!c-call:int
  22   (pid sb!c-call:int)
  23   (signal sb!c-call:int))
  24
  25 (defun unix-kill (pid signal)
  26   #!+sb-doc
  27   "Unix-kill sends the signal signal to the process with process
  28    id pid. Signal should be a valid signal number or a keyword of the
  29    standard UNIX signal name."
  30   (real-unix-kill pid (unix-signal-number signal)))
  31
  32 #!-sb-fluid (declaim (inline real-unix-killpg))
  33 (sb!alien:def-alien-routine ("killpg" real-unix-killpg) sb!c-call:int
  34   (pgrp sb!c-call:int)
  35   (signal sb!c-call:int))
  36
  37 (defun unix-killpg (pgrp signal)
  38   #!+sb-doc
  39   "Unix-killpg sends the signal signal to the all the process in process
  40   group PGRP. Signal should be a valid signal number or a keyword of
  41   the standard UNIX signal name."
  42   (real-unix-killpg pgrp (unix-signal-number signal)))
  43
  44 (sb!alien:def-alien-routine ("sigblock" unix-sigblock) sb!c-call:unsigned-long
  45   #!+sb-doc
  46   "Unix-sigblock cause the signals specified in mask to be
  47    added to the set of signals currently being blocked from
  48    delivery. The macro sigmask is provided to create masks."
  49   (mask sb!c-call:unsigned-long))
  50
  51 (sb!alien:def-alien-routine ("sigpause" unix-sigpause) sb!c-call:void
  52   #!+sb-doc
  53   "Unix-sigpause sets the set of masked signals to its argument
  54    and then waits for a signal to arrive, restoring the previous
  55    mask upon its return."
  56   (mask sb!c-call:unsigned-long))
  57
  58 (sb!alien:def-alien-routine ("sigsetmask" unix-sigsetmask)
  59                             sb!c-call:unsigned-long
  60   #!+sb-doc
  61   "Unix-sigsetmask sets the current set of masked signals (those
  62    begin blocked from delivery) to the argument. The macro sigmask
  63    can be used to create the mask. The previous value of the signal
  64    mask is returned."
  65   (mask sb!c-call:unsigned-long))
  66 \f
  67 ;;;; C routines that actually do all the work of establishing signal handlers
  68 (sb!alien:def-alien-routine ("install_handler" install-handler)
  69                             sb!c-call:unsigned-long
  70   (signal sb!c-call:int)
  71   (handler sb!c-call:unsigned-long))
  72 \f
  73 ;;;; interface to enabling and disabling signal handlers
  74
  75 (defun enable-interrupt (signal-designator handler)
  76   (declare (type (or function (member :default :ignore)) handler))
  77   (without-gcing
  78    (let ((result (install-handler (unix-signal-number signal-designator)
  79                                   (case handler
  80                                     (:default sig_dfl)
  81                                     (:ignore sig_ign)
  82                                     (t
  83                                      (sb!kernel:get-lisp-obj-address
  84                                       handler))))))
  85      (cond ((= result sig_dfl) :default)
  86            ((= result sig_ign) :ignore)
  87            (t (the function (sb!kernel:make-lisp-obj result)))))))
  88
  89 (defun default-interrupt (signal)
  90   (enable-interrupt signal :default))
  91
  92 (defun ignore-interrupt (signal)
  93   (enable-interrupt signal :ignore))
  94 \f
  95 ;;;; default LISP signal handlers
  96 ;;;;
  97 ;;;; Most of these just call ERROR to report the presence of the signal.
  98
  99 ;;; SIGINT is handled like BREAK, except that ANSI BREAK ignores
 100 ;;; *DEBUGGER-HOOK*, but we want SIGINT's BREAK to respect it, so that
 101 ;;; SIGINT in --noprogrammer mode will cleanly terminate the system
 102 ;;; (by respecting the *DEBUGGER-HOOK* established in that mode).
 103 (defun sigint-%break (format-string &rest format-arguments)
 104   (apply #'%break 'sigint format-string format-arguments))
 105
 106 (eval-when (:compile-toplevel :execute)
 107   (sb!xc:defmacro define-signal-handler (name
 108                                          what
 109                                          &optional (function 'error))
 110     `(defun ,name (signal info context)
 111        (declare (ignore signal info))
 112        (declare (type system-area-pointer context))
 113        (/show "in Lisp-level signal handler" (sap-int context))
 114        (,function ,(concatenate 'simple-string what " at #X~X")
 115                   (with-alien ((context (* os-context-t) context))
 116                     (sap-int (sb!vm:context-pc context)))))))
 117
 118 (define-signal-handler sigint-handler "interrupted" sigint-%break)
 119 (define-signal-handler sigill-handler "illegal instruction")
 120 (define-signal-handler sigtrap-handler "breakpoint/trap")
 121 (define-signal-handler sigiot-handler "SIGIOT")
 122 #!-linux
 123 (define-signal-handler sigemt-handler "SIGEMT")
 124 (define-signal-handler sigbus-handler "bus error")
 125 (define-signal-handler sigsegv-handler "segmentation violation")
 126 #!-linux
 127 (define-signal-handler sigsys-handler "bad argument to a system call")
 128 (define-signal-handler sigpipe-handler "SIGPIPE")
 129 (define-signal-handler sigalrm-handler "SIGALRM")
 130
 131 (defun sigquit-handler (signal code context)
 132   (declare (ignore signal code context))
 133   (throw 'sb!impl::top-level-catcher nil))
 134
 135 (defun sb!kernel:signal-cold-init-or-reinit ()
 136   #!+sb-doc
 137   "Enable all the default signals that Lisp knows how to deal with."
 138   (enable-interrupt :sigint #'sigint-handler)
 139   (enable-interrupt :sigquit #'sigquit-handler)
 140   (enable-interrupt :sigill #'sigill-handler)
 141   (enable-interrupt :sigtrap #'sigtrap-handler)
 142   (enable-interrupt :sigiot #'sigiot-handler)
 143   #!-linux
 144   (enable-interrupt :sigemt #'sigemt-handler)
 145   (enable-interrupt :sigfpe #'sb!vm:sigfpe-handler)
 146   (enable-interrupt :sigbus #'sigbus-handler)
 147   (enable-interrupt :sigsegv #'sigsegv-handler)
 148   #!-linux
 149   (enable-interrupt :sigsys #'sigsys-handler)
 150   (enable-interrupt :sigpipe #'sigpipe-handler)
 151   (enable-interrupt :sigalrm #'sigalrm-handler)
 152   (values))
 153 \f
 154 ;;;; etc.
 155
 156 ;;; CMU CL comment:
 157 ;;;   Magically converted by the compiler into a break instruction.
 158 (defun do-pending-interrupt ()
 159   (do-pending-interrupt))
 160 \f
 161 ;;; stale code which I'm insufficiently motivated to test -- WHN 19990714
 162 #|
 163 ;;;; WITH-ENABLED-INTERRUPTS
 164
 165 (defmacro with-enabled-interrupts (interrupt-list &body body)
 166   #!+sb-doc
 167   "With-enabled-interrupts ({(interrupt function)}*) {form}*
 168    Establish function as a handler for the Unix signal interrupt which
 169    should be a number between 1 and 31 inclusive."
 170   (let ((il (gensym))
 171         (it (gensym)))
 172     `(let ((,il NIL))
 173        (unwind-protect
 174            (progn
 175              ,@(do* ((item interrupt-list (cdr item))
 176                      (intr (caar item) (caar item))
 177                      (ifcn (cadar item) (cadar item))
 178                      (forms NIL))
 179                     ((null item) (nreverse forms))
 180                  (when (symbolp intr)
 181                    (setq intr (symbol-value intr)))
 182                  (push `(push `(,,intr ,(enable-interrupt ,intr ,ifcn)) ,il)
 183                        forms))
 184              ,@body)
 185          (dolist (,it (nreverse ,il))
 186            (enable-interrupt (car ,it) (cadr ,it)))))))
 187 |#