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