(in-package "SB!UNIX")
-;;; These should probably be somewhere, but I don't know where.
-(defconstant sig_dfl 0)
-(defconstant sig_ign 1)
+(defun invoke-interruption (function)
+ (without-interrupts
+ ;; Reset signal mask: the C-side handler has blocked all
+ ;; deferrable interrupts before arranging return to lisp. This is
+ ;; safe because we can't get a pending interrupt before we unblock
+ ;; signals.
+ ;;
+ ;; FIXME: Should we not reset the _entire_ mask, just restore it
+ ;; to the state before we got the interrupt?
+ (reset-signal-mask)
+ (allow-with-interrupts (funcall function))))
+
+(defmacro in-interruption ((&rest args) &body body)
+ #!+sb-doc
+ "Convenience macro on top of INVOKE-INTERRUPTION."
+ `(invoke-interruption (lambda () ,@body) ,@args))
\f
;;;; system calls that deal with signals
;;; 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))
(defun enable-interrupt (signal handler)
(declare (type (or function fixnum (member :default :ignore)) handler))
(/show0 "enable-interrupt")
- (without-gcing
- (let ((result (install-handler signal
- (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 (or function fixnum) (sb!kernel:make-lisp-obj result)))))))
+ (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))
;;; *DEBUGGER-HOOK*, but we want SIGINT's BREAK to respect it, so that
;;; 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))
-
(eval-when (:compile-toplevel :execute)
- (sb!xc:defmacro define-signal-handler (name
- what
- &optional (function 'error))
+ (sb!xc:defmacro define-signal-handler (name 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" ,(symbol-name name) (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")
-(define-signal-handler sigtrap-handler "breakpoint/trap")
-(define-signal-handler sigiot-handler "SIGIOT")
#!-linux
(define-signal-handler sigemt-handler "SIGEMT")
(define-signal-handler sigbus-handler "bus error")
(define-signal-handler sigsegv-handler "segmentation violation")
#!-linux
(define-signal-handler sigsys-handler "bad argument to a system call")
-(define-signal-handler sigpipe-handler "SIGPIPE")
+
+(defun sigint-handler (signal info context)
+ (declare (ignore signal info))
+ (declare (type system-area-pointer context))
+ (/show "in Lisp-level SIGINT handler" (sap-int context))
+ (flet ((interrupt-it ()
+ (with-alien ((context (* os-context-t) context))
+ (%break 'sigint 'interactive-interrupt
+ :context context
+ :address (sap-int (sb!vm:context-pc context))))))
+ (sb!thread:interrupt-thread (sb!thread::foreground-thread)
+ #'interrupt-it)))
(defun sigalrm-handler (signal info context)
(declare (ignore signal info context))
(declare (type system-area-pointer context))
- (cerror "Continue" 'sb!ext::timeout))
+ (sb!impl::run-expired-timers))
-(defun sigquit-handler (signal code context)
+(defun sigterm-handler (signal code context)
(declare (ignore signal code context))
- (throw 'sb!impl::toplevel-catcher nil))
+ (sb!thread::terminate-session)
+ (sb!ext:quit))
+
+;; Also known as SIGABRT.
+(defun sigiot-handler (signal code context)
+ (declare (ignore signal code context))
+ (sb!impl::%halt))
(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 sigterm #'sigterm-handler)
(enable-interrupt sigill #'sigill-handler)
- (enable-interrupt sigtrap #'sigtrap-handler)
(enable-interrupt sigiot #'sigiot-handler)
#!-linux
(enable-interrupt sigemt #'sigemt-handler)
(enable-interrupt sigsegv #'sigsegv-handler)
#!-linux
(enable-interrupt sigsys #'sigsys-handler)
- (enable-interrupt sigpipe #'sigpipe-handler)
+ (ignore-interrupt sigpipe)
(enable-interrupt sigalrm #'sigalrm-handler)
+ (sb!unix::reset-signal-mask)
(values))
\f
;;;; etc.
+;;; extract si_code from siginfo_t
+(sb!alien:define-alien-routine ("siginfo_code" siginfo-code) sb!alien:int
+ (info system-area-pointer))
+
;;; CMU CL comment:
;;; Magically converted by the compiler into a break instruction.
(defun receive-pending-interrupt ()
(receive-pending-interrupt))
-\f
-;;; stale code which I'm insufficiently motivated to test -- WHN 19990714
-#|
-;;;; WITH-ENABLED-INTERRUPTS
-
-(defmacro with-enabled-interrupts (interrupt-list &body body)
- #!+sb-doc
- "With-enabled-interrupts ({(interrupt function)}*) {form}*
- 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)))
- `(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)))))))
-|#
projects / sbcl.git / blobdiff