Inherit FP modes for new threads on Windows.

[sbcl.git] / src / code / signal.lisp

diff --git a/src/code/signal.lisp b/src/code/signal.lisp
index 4040857..945f77c 100644 (file)
--- 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,7 +103,7 @@ WITHOUT-INTERRUPTS in:
     (lambda () (with-local-interrupts ...)))
 "
   (with-unique-names (outer-allow-with-interrupts without-interrupts-body)
-    `(flet ((,without-interrupts-body ()
+    `(dx-flet ((,without-interrupts-body ()
               (declare (disable-package-locks allow-with-interrupts
                                               with-local-interrupts))
               (macrolet
@@ -105,9 +118,14 @@ WITHOUT-INTERRUPTS in:
                              ,',outer-allow-with-interrupts)
                             (*interrupts-enabled*
                              ,',outer-allow-with-interrupts))
-                        (when (and ,',outer-allow-with-interrupts
-                                   *interrupt-pending*)
-                          (receive-pending-interrupt))
+                        (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*)
@@ -128,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)))))
 
@@ -149,8 +168,13 @@ 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)
@@ -163,11 +187,12 @@ by ALLOW-WITH-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))))