(in-package "SB!UNIX")
+(defmacro with-interrupt-bindings (&body body)
+ (with-unique-names (empty)
+ `(let*
+ ;; KLUDGE: Whatever is on the PCL stacks before the interrupt
+ ;; handler runs doesn't really matter, since we're not on the
+ ;; same call stack, really -- and if we don't bind these (esp.
+ ;; the cache one) we can get a bogus metacircle if an interrupt
+ ;; handler calls a GF that was being computed when the interrupt
+ ;; hit.
+ ((sb!pcl::*cache-miss-values-stack* nil)
+ (sb!pcl::*dfun-miss-gfs-on-stack* nil)
+ ;; Unless we do this, ADJUST-ARRAY and SORT would need to
+ ;; disable interrupts.
+ (,empty (vector))
+ (sb!impl::*zap-array-data-temp* ,empty)
+ (sb!impl::*merge-sort-temp-vector* ,empty))
+ ,@body)))
+
+;;; Evaluate CLEANUP-FORMS iff PROTECTED-FORM does a non-local exit.
+(defmacro nlx-protect (protected-form &rest cleanup-froms)
+ (with-unique-names (completep)
+ `(let ((,completep nil))
+ (without-interrupts
+ (unwind-protect
+ (progn
+ (allow-with-interrupts
+ ,protected-form)
+ (setq ,completep t))
+ (unless ,completep
+ ,@cleanup-froms))))))
+
(defun invoke-interruption (function)
(without-interrupts
- ;; FIXME: This is wrong. Imagine the following sequence:
- ;;
- ;; 1. an asynch interrupt arrives after entry to
- ;; WITHOUT-INTERRUPTS but before RESET-SIGNAL-MASK: pending
- ;; machinery blocks all signals and marks the signal as
- ;; pending.
- ;;
- ;; 2. RESET-SIGNAL-MASK is called, and all signals are unblocked.
- ;;
- ;; 3. Another signal arrives while we already have one pending.
- ;; Oops -- we lose().
- ;;
- ;; Not sure what the right thing is, but definitely not
- ;; RESET-SIGNAL-MASK. Removing it breaks signals.impure.lisp
- ;; right now, though, and this is a rare race, so...
- (reset-signal-mask)
- (funcall function)))
-
-(defmacro in-interruption ((&rest args) &body body)
+ ;; Reset signal mask: the C-side handler has blocked all
+ ;; deferrable signals before funcalling into lisp. They are to be
+ ;; unblocked the first time interrupts are enabled. With this
+ ;; mechanism there are no extra frames on the stack from a
+ ;; previous signal handler when the next signal is delivered
+ ;; provided there is no WITH-INTERRUPTS.
+ (let ((*unblock-deferrables-on-enabling-interrupts-p* t))
+ (with-interrupt-bindings
+ (let ((sb!debug:*stack-top-hint*
+ (nth-value 1 (sb!kernel:find-interrupted-name-and-frame))))
+ (allow-with-interrupts
+ (nlx-protect (funcall function)
+ ;; We've been running with deferrables
+ ;; blocked in Lisp called by a C signal
+ ;; handler. If we return normally the sigmask
+ ;; in the interrupted context is restored.
+ ;; However, if we do an nlx the operating
+ ;; system will not restore it for us.
+ (when *unblock-deferrables-on-enabling-interrupts-p*
+ ;; This means that storms of interrupts
+ ;; doing an nlx can still run out of stack.
+ (unblock-deferrable-signals)))))))))
+
+(defmacro in-interruption ((&key) &body body)
#!+sb-doc
"Convenience macro on top of INVOKE-INTERRUPTION."
- `(invoke-interruption (lambda () ,@body) ,@args))
+ `(dx-flet ((interruption () ,@body))
+ (invoke-interruption #'interruption)))
\f
;;;; system calls that deal with signals
;;; 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)
+(declaim (inline %unblock-deferrable-signals %unblock-gc-signals))
+(sb!alien:define-alien-routine ("unblock_deferrable_signals"
+ %unblock-deferrable-signals)
+ sb!alien:void
+ (where sb!alien:unsigned-long)
+ (old sb!alien:unsigned-long))
+(sb!alien:define-alien-routine ("unblock_gc_signals" %unblock-gc-signals)
+ sb!alien:void
+ (where sb!alien:unsigned-long)
+ (old sb!alien:unsigned-long))
+
+(defun unblock-deferrable-signals ()
+ (%unblock-deferrable-signals 0 0))
+
+(defun unblock-gc-signals ()
+ (%unblock-gc-signals 0 0))
\f
;;;; C routines that actually do all the work of establishing signal handlers
(declare (type (or function fixnum (member :default :ignore)) handler))
(/show0 "enable-interrupt")
(flet ((run-handler (&rest args)
+ (declare (truly-dynamic-extent args))
(in-interruption ()
(apply handler args))))
(without-gcing
#!-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")
(/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))))))
+ (with-interrupts
+ (%break 'sigint 'interactive-interrupt
+ :context context
+ :address (sap-int (sb!vm:context-pc context)))))))
(sb!thread:interrupt-thread (sb!thread::foreground-thread)
#'interrupt-it)))
(sb!thread::terminate-session)
(sb!ext:quit))
-;; Also known as SIGABRT.
-(defun sigiot-handler (signal code context)
+;;; SIGPIPE is not used in SBCL for its original purpose, instead it's
+;;; for signalling a thread that it should look at its interruption
+;;; queue. The handler (RUN_INTERRUPTION) just returns if there is
+;;; nothing to do so it's safe to receive spurious SIGPIPEs coming
+;;; from the kernel.
+(defun sigpipe-handler (signal code context)
(declare (ignore signal code context))
- (sb!impl::%halt))
+ (sb!thread::run-interruption))
(defun sb!kernel:signal-cold-init-or-reinit ()
#!+sb-doc
(enable-interrupt sigint #'sigint-handler)
(enable-interrupt sigterm #'sigterm-handler)
(enable-interrupt sigill #'sigill-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)
#!-linux
(enable-interrupt sigsys #'sigsys-handler)
- (ignore-interrupt sigpipe)
(enable-interrupt sigalrm #'sigalrm-handler)
- (sb!unix::reset-signal-mask)
+ (enable-interrupt sigpipe #'sigpipe-handler)
+ #!+hpux (ignore-interrupt sigxcpu)
+ (unblock-gc-signals)
+ (unblock-deferrable-signals)
(values))
\f
;;;; etc.
;;; 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