Update of /cvsroot/sbcl/sbcl/src/code
In directory sc8-pr-cvs8.sourceforge.net:/tmp/cvs-serv21385/src/code
Modified Files:
early-impl.lisp signal.lisp target-signal.lisp
target-thread.lisp
Log Message:
1.0.5.56: conditionally re-enable interrupts interrupting current thread
* New variable: *IN-INTERRUPTION* is true IFF we're being called inside
*IN-INTERRUPTION* and there are no intervening WITHOUT-INTERRUPTS.
* INTERRUPT-THREAD calls the interrupt function inside WITH-INTERRUPTS
when interrupting the current thread IFF *IN-INTERRUPTION* is true.
* Remove bogus FIXME by yours truly from INVOKE-INTERRUPTION and
properly explain what is going on -- and add another FIXME in its
place.
This makes nested SIGINTs DTRT.
Index: early-impl.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/early-impl.lisp,v
retrieving revision 1.20
retrieving revision 1.21
diff -u -d -r1.20 -r1.21
--- early-impl.lisp 6 Apr 2007 09:58:08 -0000 1.20
+++ early-impl.lisp 20 May 2007 12:34:33 -0000 1.21
@@ -33,6 +33,7 @@
;; pseudo-atomicity too, but they handle it without
;; messing with special variables.)
#!+(or x86 x86-64) *pseudo-atomic-bits*
+ *in-interruption*
*interrupts-enabled*
*interrupt-pending*
*free-interrupt-context-index*
Index: signal.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/signal.lisp,v
retrieving revision 1.18
retrieving revision 1.19
diff -u -d -r1.18 -r1.19
--- signal.lisp 6 Apr 2007 09:58:08 -0000 1.18
+++ signal.lisp 20 May 2007 12:34:33 -0000 1.19
@@ -40,6 +40,14 @@
(defvar *interrupts-enabled* t)
(defvar *interrupt-pending* nil)
+;;; KLUDGE: This tells INTERRUPT-THREAD that it is being invoked as an
+;;; interruption, so that if the thread being interrupted is the
+;;; current thread it knows to enable interrupts. INVOKE-INTERRUPTION
+;;; binds it to T, and WITHOUT-INTERRUPTS binds it to NIL, so that if
+;;; interrupts are disable between INTERRUPT-THREAD and this we don't
+;;; accidentally re-enable them.
+(defvar *in-interruption* nil)
+
(sb!xc:defmacro without-interrupts (&body body)
#!+sb-doc
"Execute BODY with all deferrable interrupts deferred. Deferrable interrupts
@@ -51,7 +59,8 @@
`(flet ((,name () ,@body))
(if *interrupts-enabled*
(unwind-protect
- (let ((*interrupts-enabled* nil))
+ (let ((*interrupts-enabled* nil)
+ (*in-interruption* nil))
(,name))
;; If we were interrupted in the protected section, then
;; the interrupts are still blocked and it remains so
Index: target-signal.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/target-signal.lisp,v
retrieving revision 1.38
retrieving revision 1.39
diff -u -d -r1.38 -r1.39
--- target-signal.lisp 18 Apr 2007 15:26:21 -0000 1.38
+++ target-signal.lisp 20 May 2007 12:34:33 -0000 1.39
@@ -13,23 +13,17 @@
(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().
+ ;; 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.
;;
- ;; 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...
+ ;; FIXME: Should we not reset the _entire_ mask, just restore it
+ ;; to the state before we got the interrupt?
(reset-signal-mask)
- (funcall function)))
+ ;; Tell INTERRUPT-THREAD it's ok to re-enable interrupts.
+ (let ((*in-interruption* t))
+ (funcall function))))
(defmacro in-interruption ((&rest args) &body body)
#!+sb-doc
Index: target-thread.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/target-thread.lisp,v
retrieving revision 1.75
retrieving revision 1.76
diff -u -d -r1.75 -r1.76
--- target-thread.lisp 30 Apr 2007 10:35:32 -0000 1.75
+++ target-thread.lisp 20 May 2007 12:34:34 -0000 1.76
@@ -733,13 +733,15 @@
(with-mutex ((thread-interruptions-lock ,thread))
,@body)))
-;; Called from the signal handler.
+;; Called from the signal handler in C.
(defun run-interruption ()
(in-interruption ()
(loop
(let ((interruption (with-interruptions-lock (*current-thread*)
(pop (thread-interruptions *current-thread*)))))
(if interruption
+ ;; This is safe because it's the IN-INTERRUPTION that
+ ;; has disabled interrupts.
(with-interrupts
(funcall interruption))
(return))))))
@@ -759,21 +761,29 @@
then do something that turns out to need those locks, you probably
won't like the effect."
#!-sb-thread (declare (ignore thread))
- ;; not quite perfect, because it does not take WITHOUT-INTERRUPTS
- ;; into account
- #!-sb-thread
- (funcall function)
- #!+sb-thread
- (if (eq thread *current-thread*)
- (funcall function)
- (let ((os-thread (thread-os-thread thread)))
- (cond ((not os-thread)
- (error 'interrupt-thread-error :thread thread))
- (t
- (with-interruptions-lock (thread)
- (push function (thread-interruptions thread)))
- (when (minusp (signal-interrupt-thread os-thread))
- (error 'interrupt-thread-error :thread thread)))))))
+ (flet ((interrupt-self ()
+ ;; *IN-INTERRUPTION* is true IFF we're being called as an
+ ;; interruption without an intervening WITHOUT-INTERRUPTS,
+ ;; in which case it is safe to enable interrupts. Otherwise
+ ;; interrupts are either already enabled, or there is an outer
+ ;; WITHOUT-INTERRUPTS we know nothing about, which makes it
+ ;; unsafe to enable interrupts.
+ (if *in-interruption*
+ (with-interrupts (funcall function))
+ (funcall function))))
+ #!-sb-thread
+ (interrupt-self)
+ #!+sb-thread
+ (if (eq thread *current-thread*)
+ (interrupt-self)
+ (let ((os-thread (thread-os-thread thread)))
+ (cond ((not os-thread)
+ (error 'interrupt-thread-error :thread thread))
+ (t
+ (with-interruptions-lock (thread)
+ (push function (thread-interruptions thread)))
+ (when (minusp (signal-interrupt-thread os-thread))
+ (error 'interrupt-thread-error :thread thread))))))))
(defun terminate-thread (thread)
#!+sb-doc
|