X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ftarget-signal.lisp;h=bea8892e2bd3d08d22819169b5e1fbf02da7e31b;hb=20db73fc9412b7d9bd92f93239d7f34a261d5402;hp=a3412078ea196a24e32604b0e69f66c6e776bc42;hpb=4a3c4dc2899b799cbfa4f76dfc80123dc855f281;p=sbcl.git

diff --git a/src/code/target-signal.lisp b/src/code/target-signal.lisp
index a341207..bea8892 100644
--- a/src/code/target-signal.lisp
+++ b/src/code/target-signal.lisp
@@ -12,36 +12,54 @@
 (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)))
+  `(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))
+     ,@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
-    (with-interrupt-bindings
-      ;; 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.
-      ;;
-      ;; FIXME: Should we not reset the _entire_ mask, but just
-      ;; restore it to the state before we got the interrupt?
-      (reset-signal-mask)
-      (let ((sb!debug:*stack-top-hint* (nth-value 1 (sb!kernel:find-interrupted-name-and-frame))))
-        (allow-with-interrupts (funcall function))))))
+    ;; 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
@@ -75,9 +93,22 @@
 ;;; 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))
 
 
 ;;;; C routines that actually do all the work of establishing signal handlers
@@ -138,7 +169,6 @@
 #!-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")
 
@@ -148,9 +178,14 @@
   (/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
+               (let ((int (make-condition 'interactive-interrupt
+                                          :context context
+                                          :address (sap-int (sb!vm:context-pc context)))))
+                 ;; First SIGNAL, so that handlers can run.
+                 (signal int)
+                 ;; Then enter the debugger like BREAK.
+                 (%break 'sigint int))))))
     (sb!thread:interrupt-thread (sb!thread::foreground-thread)
                                 #'interrupt-it)))
 
@@ -164,6 +199,20 @@
   (sb!thread::terminate-session)
   (sb!ext:quit))
 
+;;; 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!thread::run-interruption))
+
+;;; the handler for SIGCHLD signals for RUN-PROGRAM
+(defun sigchld-handler  (signal code context)
+  (declare (ignore signal code context))
+  (sb!impl::get-processes-status-changes))
+
 (defun sb!kernel:signal-cold-init-or-reinit ()
   #!+sb-doc
   "Enable all the default signals that Lisp knows how to deal with."
@@ -174,13 +223,14 @@
   (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)
+  (enable-interrupt sigpipe #'sigpipe-handler)
+  (enable-interrupt sigchld #'sigchld-handler)
   #!+hpux (ignore-interrupt sigxcpu)
-  (sb!unix::reset-signal-mask)
+  (unblock-gc-signals)
+  (unblock-deferrable-signals)
   (values))
 
 ;;;; etc.