(in-package "SB!UNIX")
+(defun invoke-interruption (function)
+ (without-interrupts
+ (sb!unix::reset-signal-mask)
+ (funcall function)))
+
+(defmacro in-interruption ((&rest args) &body body)
+ #!+sb-doc
+ "Convenience macro on top of INVOKE-INTERRUPTION."
+ `(invoke-interruption (lambda () ,@body) ,@args))
+
;;; These should probably be somewhere, but I don't know where.
(defconstant sig_dfl 0)
(defconstant sig_ign 1)
\f
;;;; system calls that deal with signals
+;;; Send the signal SIGNAL to the process with process id PID. SIGNAL
+;;; should be a valid signal number
#!-sb-fluid (declaim (inline real-unix-kill))
-(sb!alien:define-alien-routine ("kill" real-unix-kill) sb!alien:int
+(sb!alien:define-alien-routine ("kill" unix-kill) sb!alien:int
(pid sb!alien:int)
(signal sb!alien:int))
-;;; Send the signal SIGNAL to the process with process id PID. SIGNAL
-;;; should be a valid signal number or a keyword of the standard UNIX
-;;; signal name.
-(defun unix-kill (pid signal)
- (real-unix-kill pid (unix-signal-number signal)))
-
+;;; Send the signal SIGNAL to the all the process in process group
+;;; PGRP. SIGNAL should be a valid signal number
#!-sb-fluid (declaim (inline real-unix-killpg))
-(sb!alien:define-alien-routine ("killpg" real-unix-killpg) sb!alien:int
+(sb!alien:define-alien-routine ("killpg" unix-killpg) sb!alien:int
(pgrp sb!alien:int)
(signal sb!alien:int))
-;;; Send the signal SIGNAL to the all the process in process group
-;;; PGRP. SIGNAL should be a valid signal number or a keyword of the
-;;; standard UNIX signal name.
-(defun unix-killpg (pgrp signal)
- (real-unix-killpg pgrp (unix-signal-number signal)))
-
-;;; Set the current set of masked signals (those being blocked from
+;;; Reset the current set of masked signals (those being blocked from
;;; delivery).
;;;
-;;; (Note: CMU CL had a SIGMASK operator to create masks, but since
-;;; SBCL only uses 0, we no longer support it. If you need it, you
-;;; can pull it out of the CMU CL sources, or the old SBCL sources;
-;;; but you might also consider doing things the SBCL way and moving
-;;; this kind of C-level work down to C wrapper functions.)
-#!-sunos
-(sb!alien:define-alien-routine ("sigsetmask" unix-sigsetmask)
- sb!alien:unsigned-long
- (mask sb!alien:unsigned-long))
+;;; (Note: CMU CL had a more general SIGSETMASK call and a SIGMASK
+;;; operator to create masks, but since we only ever reset to 0, we no
+;;; longer support it. If you need it, you can pull it out of the CMU
+;;; CL sources, or the old SBCL sources; but you might also consider
+;;; doing things the SBCL way and moving this kind of C-level work
+;;; down to C wrapper functions.)
+
+;;; When inappropriate build options are used, this also prints messages
+;;; listing the signals that were masked
+(sb!alien:define-alien-routine "reset_signal_mask" sb!alien:void)
+
\f
;;;; C routines that actually do all the work of establishing signal handlers
(sb!alien:define-alien-routine ("install_handler" install-handler)
- sb!alien:unsigned-long
+ sb!alien:unsigned-long
(signal sb!alien:int)
(handler sb!alien:unsigned-long))
-\f
+
;;;; interface to enabling and disabling signal handlers
-(defun enable-interrupt (signal-designator handler)
- (declare (type (or function (member :default :ignore)) handler))
- (without-gcing
- (let ((result (install-handler (unix-signal-number signal-designator)
- (case handler
- (:default sig_dfl)
- (:ignore sig_ign)
- (t
- (sb!kernel:get-lisp-obj-address
- handler))))))
- (cond ((= result sig_dfl) :default)
- ((= result sig_ign) :ignore)
- (t (the function (sb!kernel:make-lisp-obj result)))))))
+(defun enable-interrupt (signal handler)
+ (declare (type (or function fixnum (member :default :ignore)) handler))
+ (/show0 "enable-interrupt")
+ (flet ((run-handler (&rest args)
+ (in-interruption ()
+ (apply handler args))))
+ (without-gcing
+ (let ((result (install-handler signal
+ (case handler
+ (:default sig_dfl)
+ (:ignore sig_ign)
+ (t
+ (sb!kernel:get-lisp-obj-address
+ #'run-handler))))))
+ (cond ((= result sig_dfl) :default)
+ ((= result sig_ign) :ignore)
+ (t (the (or function fixnum)
+ (sb!kernel:make-lisp-obj result))))))))
(defun default-interrupt (signal)
(enable-interrupt signal :default))
;;; SIGINT in --disable-debugger mode will cleanly terminate the system
;;; (by respecting the *DEBUGGER-HOOK* established in that mode).
(defun sigint-%break (format-string &rest format-arguments)
- (apply #'%break 'sigint format-string format-arguments))
+ (flet ((break-it ()
+ (apply #'%break 'sigint format-string format-arguments)))
+ (sb!thread:interrupt-thread (sb!thread::foreground-thread) #'break-it)))
(eval-when (:compile-toplevel :execute)
(sb!xc:defmacro define-signal-handler (name
- what
- &optional (function 'error))
+ what
+ &optional (function 'error))
`(defun ,name (signal info context)
(declare (ignore signal info))
(declare (type system-area-pointer context))
- (/show "in Lisp-level signal handler" (sap-int context))
- (,function ,(concatenate 'simple-string what " at #X~X")
- (with-alien ((context (* os-context-t) context))
- (sap-int (sb!vm:context-pc context)))))))
+ (/show "in Lisp-level signal handler" ,(symbol-name name)
+ (sap-int context))
+ (with-interrupts
+ (,function ,(concatenate 'simple-string what " at #X~X")
+ (with-alien ((context (* os-context-t) context))
+ (sap-int (sb!vm:context-pc context))))))))
(define-signal-handler sigint-handler "interrupted" sigint-%break)
(define-signal-handler sigill-handler "illegal instruction")
#!-linux
(define-signal-handler sigsys-handler "bad argument to a system call")
(define-signal-handler sigpipe-handler "SIGPIPE")
-(define-signal-handler sigalrm-handler "SIGALRM")
+
+(defun sigalrm-handler (signal info context)
+ (declare (ignore signal info context))
+ (declare (type system-area-pointer context))
+ (sb!impl::run-expired-timers))
(defun sigquit-handler (signal code context)
(declare (ignore signal code context))
- (throw 'sb!impl::toplevel-catcher nil))
+ (throw 'toplevel-catcher nil))
(defun sb!kernel:signal-cold-init-or-reinit ()
#!+sb-doc
"Enable all the default signals that Lisp knows how to deal with."
- (enable-interrupt :sigint #'sigint-handler)
- (enable-interrupt :sigquit #'sigquit-handler)
- (enable-interrupt :sigill #'sigill-handler)
- (enable-interrupt :sigtrap #'sigtrap-handler)
- (enable-interrupt :sigiot #'sigiot-handler)
+ (enable-interrupt sigint #'sigint-handler)
+ (enable-interrupt sigquit #'sigquit-handler)
+ (enable-interrupt sigill #'sigill-handler)
+ (enable-interrupt sigtrap #'sigtrap-handler)
+ (enable-interrupt sigiot #'sigiot-handler)
#!-linux
- (enable-interrupt :sigemt #'sigemt-handler)
- (enable-interrupt :sigfpe #'sb!vm:sigfpe-handler)
- (enable-interrupt :sigbus #'sigbus-handler)
- (enable-interrupt :sigsegv #'sigsegv-handler)
+ (enable-interrupt sigemt #'sigemt-handler)
+ (enable-interrupt sigfpe #'sb!vm:sigfpe-handler)
+ (enable-interrupt sigbus #'sigbus-handler)
+ (enable-interrupt sigsegv #'sigsegv-handler)
#!-linux
- (enable-interrupt :sigsys #'sigsys-handler)
- (enable-interrupt :sigpipe #'sigpipe-handler)
- (enable-interrupt :sigalrm #'sigalrm-handler)
+ (enable-interrupt sigsys #'sigsys-handler)
+ (enable-interrupt sigpipe #'sigpipe-handler)
+ (enable-interrupt sigalrm #'sigalrm-handler)
+ (sb!unix::reset-signal-mask)
(values))
\f
;;;; etc.
Establish function as a handler for the Unix signal interrupt which
should be a number between 1 and 31 inclusive."
(let ((il (gensym))
- (it (gensym)))
+ (it (gensym)))
`(let ((,il NIL))
(unwind-protect
- (progn
- ,@(do* ((item interrupt-list (cdr item))
- (intr (caar item) (caar item))
- (ifcn (cadar item) (cadar item))
- (forms NIL))
- ((null item) (nreverse forms))
- (when (symbolp intr)
- (setq intr (symbol-value intr)))
- (push `(push `(,,intr ,(enable-interrupt ,intr ,ifcn)) ,il)
- forms))
- ,@body)
- (dolist (,it (nreverse ,il))
- (enable-interrupt (car ,it) (cadr ,it)))))))
+ (progn
+ ,@(do* ((item interrupt-list (cdr item))
+ (intr (caar item) (caar item))
+ (ifcn (cadar item) (cadar item))
+ (forms NIL))
+ ((null item) (nreverse forms))
+ (when (symbolp intr)
+ (setq intr (symbol-value intr)))
+ (push `(push `(,,intr ,(enable-interrupt ,intr ,ifcn)) ,il)
+ forms))
+ ,@body)
+ (dolist (,it (nreverse ,il))
+ (enable-interrupt (car ,it) (cadr ,it)))))))
|#
projects / sbcl.git / blobdiff