X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fsignal.lisp;h=945f77cc479c57329bdf9da5d8b8f79890a36295;hb=2056118835600a7c4e372c796568ddada5824cf6;hp=d6c7eee4b41e502b8daf6bc564e3c961bcd7c27e;hpb=fe420bb47ea909070ee82c6e48642c9ff41dbcc8;p=sbcl.git

diff --git a/src/code/signal.lisp b/src/code/signal.lisp
index d6c7eee..945f77c 100644
--- a/src/code/signal.lisp
+++ b/src/code/signal.lisp
@@ -50,7 +50,20 @@
 
 (defvar *interrupts-enabled* t)
 (defvar *interrupt-pending* nil)
+#!+sb-thruption (defvar *thruption-pending* nil)
 (defvar *allow-with-interrupts* t)
+;;; This is to support signal handlers that want to return to the
+;;; interrupted context without leaving anything extra on the stack. A
+;;; simple
+;;;
+;;;  (without-interrupts
+;;;   (unblock-deferrable-signals)
+;;;   (allow-with-interrupts ...))
+;;;
+;;; would not cut it, as upon leaving WITHOUT-INTERRUPTS the pending
+;;; handlers is run with stuff from the function in which this is
+;;; still on the stack.
+(defvar *unblock-deferrables-on-enabling-interrupts-p* nil)
 
 (sb!xc:defmacro without-interrupts (&body body)
   #!+sb-doc
@@ -90,22 +103,36 @@ WITHOUT-INTERRUPTS in:
     (lambda () (with-local-interrupts ...)))
 "
   (with-unique-names (outer-allow-with-interrupts without-interrupts-body)
-    `(flet ((,without-interrupts-body ()
-              (declare (disable-package-locks allow-with-interrupts with-local-interrupts))
-              (macrolet ((allow-with-interrupts (&body allow-forms)
-                                                `(let ((*allow-with-interrupts* ,',outer-allow-with-interrupts))
-                                                   ,@allow-forms))
-                         (with-local-interrupts (&body with-forms)
-                                                `(let ((*allow-with-interrupts* ,',outer-allow-with-interrupts)
-                                                       (*interrupts-enabled* ,',outer-allow-with-interrupts))
-                                                   (when (and ,',outer-allow-with-interrupts *interrupt-pending*)
-                                                     (receive-pending-interrupt))
-                                                   (locally ,@with-forms))))
+    `(dx-flet ((,without-interrupts-body ()
+              (declare (disable-package-locks allow-with-interrupts
+                                              with-local-interrupts))
+              (macrolet
+                  ((allow-with-interrupts
+                     (&body allow-forms)
+                     `(let ((*allow-with-interrupts*
+                             ,',outer-allow-with-interrupts))
+                        ,@allow-forms))
+                   (with-local-interrupts
+                     (&body with-forms)
+                     `(let ((*allow-with-interrupts*
+                             ,',outer-allow-with-interrupts)
+                            (*interrupts-enabled*
+                             ,',outer-allow-with-interrupts))
+                        (when ,',outer-allow-with-interrupts
+                          (when *unblock-deferrables-on-enabling-interrupts-p*
+                            (setq *unblock-deferrables-on-enabling-interrupts-p*
+                                  nil)
+                            (sb!unix::unblock-deferrable-signals))
+                          (when (or *interrupt-pending*
+                                    #!+sb-thruption *thruption-pending*)
+                            (receive-pending-interrupt)))
+                        (locally ,@with-forms))))
                 (let ((*interrupts-enabled* nil)
                       (,outer-allow-with-interrupts *allow-with-interrupts*)
                       (*allow-with-interrupts* nil))
                   (declare (ignorable ,outer-allow-with-interrupts))
-                  (declare (enable-package-locks allow-with-interrupts with-local-interrupts))
+                  (declare (enable-package-locks allow-with-interrupts
+                                                 with-local-interrupts))
                   ,@body))))
        (if *interrupts-enabled*
            (unwind-protect
@@ -119,7 +146,8 @@ WITHOUT-INTERRUPTS in:
              ;; another WITHOUT-INTERRUPTS, the pending interrupt will be
              ;; handled immediately upon exit from said
              ;; WITHOUT-INTERRUPTS, so it is as if nothing has happened.
-             (when *interrupt-pending*
+             (when (or *interrupt-pending*
+                       #!+sb-thruption *thruption-pending*)
                (receive-pending-interrupt)))
            (,without-interrupts-body)))))
 
@@ -140,23 +168,31 @@ by ALLOW-WITH-INTERRUPTS."
     `(let* ((,allowp *allow-with-interrupts*)
             (,enablep *interrupts-enabled*)
             (*interrupts-enabled* (or ,enablep ,allowp)))
-       (when (and (and ,allowp (not ,enablep)) *interrupt-pending*)
-         (receive-pending-interrupt))
+       (when (and ,allowp (not ,enablep))
+         (when *unblock-deferrables-on-enabling-interrupts-p*
+           (setq *unblock-deferrables-on-enabling-interrupts-p* nil)
+           (sb!unix::unblock-deferrable-signals))
+         (when (or *interrupt-pending*
+                   #!+sb-thruption *thruption-pending*)
+           (receive-pending-interrupt)))
        (locally ,@body))))
 
 (defmacro allow-with-interrupts (&body body)
   (declare (ignore body))
-  (error "~S is valid only inside ~S." 'allow-with-interrupts 'without-interrupts))
+  (error "~S is valid only inside ~S."
+         'allow-with-interrupts 'without-interrupts))
 
 (defmacro with-local-interrupts (&body body)
   (declare (ignore body))
-  (error "~S is valid only inside ~S." 'with-local-interrupts 'without-interrupts))
+  (error "~S is valid only inside ~S."
+         'with-local-interrupts 'without-interrupts))
 
-;;; A low-level operation that assumes that *INTERRUPTS-ENABLED* is false,
-;;; and *ALLOW-WITH-INTERRUPTS* is true.
+;;; A low-level operation that assumes that *INTERRUPTS-ENABLED* is
+;;; false, *ALLOW-WITH-INTERRUPTS* is true and deferrable signals are
+;;; unblocked.
 (defun %check-interrupts ()
-  ;; Here we check for pending interrupts first, because reading a special
-  ;; is faster then binding it!
-  (when *interrupt-pending*
+  ;; Here we check for pending interrupts first, because reading a
+  ;; special is faster then binding it!
+  (when (or *interrupt-pending* #!+sb-thruption *thruption-pending*)
     (let ((*interrupts-enabled* t))
       (receive-pending-interrupt))))