Further work towards use of win32 file HANDLEs

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

diff --git a/src/code/target-signal.lisp b/src/code/target-signal.lisp
index 840604e..9fab9d1 100644 (file)
--- a/src/code/target-signal.lisp
+++ b/src/code/target-signal.lisp
@@ -44,23 +44,22 @@
     ;; 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))
+    (let ((*unblock-deferrables-on-enabling-interrupts-p* t)
+          (sb!debug:*stack-top-hint* (or sb!debug:*stack-top-hint* 'invoke-interruption)))
       (with-interrupt-bindings
-        (let ((sb!debug:*stack-top-hint*
-                (nth-value 1 (sb!kernel:find-interrupted-name-and-frame))))
-          (sb!thread::without-thread-waiting-for (:already-without-interrupts t)
-              (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))))))))))
+        (sb!thread::without-thread-waiting-for (:already-without-interrupts t)
+          (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
@@ -100,6 +99,7 @@
     sb!alien:void
   (where sb!alien:unsigned-long)
   (old sb!alien:unsigned-long))
+#!-sb-safepoint
 (sb!alien:define-alien-routine ("unblock_gc_signals" %unblock-gc-signals)
     sb!alien:void
   (where sb!alien:unsigned-long)
@@ -108,6 +108,7 @@
 (defun unblock-deferrable-signals ()
   (%unblock-deferrable-signals 0 0))
 
+#!-sb-safepoint
 (defun unblock-gc-signals ()
   (%unblock-gc-signals 0 0))
 
@@ -187,9 +188,26 @@
                  (signal int)
                  ;; Then enter the debugger like BREAK.
                  (%break 'sigint int))))))
+    #!+sb-safepoint
+    (let ((target (sb!thread::foreground-thread)))
+      ;; Note that INTERRUPT-THREAD on *CURRENT-THREAD* doesn't actually
+      ;; interrupt right away, because deferrables are blocked.  Rather,
+      ;; the kernel would arrange for the SIGPIPE to hit when the SIGINT
+      ;; handler is done.  However, on safepoint builds, we don't use
+      ;; SIGPIPE and lack an appropriate mechanism to handle pending
+      ;; thruptions upon exit from signal handlers (and this situation is
+      ;; unlike WITHOUT-INTERRUPTS, which handles pending interrupts
+      ;; explicitly at the end).  Only as long as safepoint builds pretend
+      ;; to cooperate with signals -- that is, as long as SIGINT-HANDLER
+      ;; is used at all -- detect this situation and work around it.
+      (if (eq target sb!thread:*current-thread*)
+          (interrupt-it)
+          (sb!thread:interrupt-thread target #'interrupt-it)))
+    #!-sb-safepoint
     (sb!thread:interrupt-thread (sb!thread::foreground-thread)
                                 #'interrupt-it)))
 
+#!-sb-wtimer
 (defun sigalrm-handler (signal info context)
   (declare (ignore signal info context))
   (declare (type system-area-pointer context))
@@ -199,6 +217,7 @@
   (declare (ignore signal code context))
   (sb!ext:exit))
 
+#!-sb-thruption
 ;;; 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
@@ -225,11 +244,13 @@
   (enable-interrupt sigbus #'sigbus-handler)
   #!-linux
   (enable-interrupt sigsys #'sigsys-handler)
+  #!-sb-wtimer
   (enable-interrupt sigalrm #'sigalrm-handler)
+  #!-sb-thruption
   (enable-interrupt sigpipe #'sigpipe-handler)
   (enable-interrupt sigchld #'sigchld-handler)
   #!+hpux (ignore-interrupt sigxcpu)
-  (unblock-gc-signals)
+  #!-sb-safepoint (unblock-gc-signals)
   (unblock-deferrable-signals)
   (values))
 \f