X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ftarget-signal.lisp;h=7394695713d07dc98e9e7ba53a91491d64c2a24d;hb=d720bc359f03734ccb9baf66cb45dc01d623f369;hp=87cf646399de535b799b71051cf47809e8278e72;hpb=64eccd1724e5f1e638bfc574f7f376427ee3dcb1;p=sbcl.git

diff --git a/src/code/target-signal.lisp b/src/code/target-signal.lisp
index 87cf646..7394695 100644
--- a/src/code/target-signal.lisp
+++ b/src/code/target-signal.lisp
@@ -12,22 +12,16 @@
 (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)
@@ -50,10 +44,10 @@
     ;; 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
@@ -99,8 +93,22 @@
 ;;; doing things the SBCL way and moving this kind of C-level work
 ;;; down to C wrapper functions.)
 
-(sb!alien:define-alien-routine "unblock_deferrable_signals" sb!alien:void)
-(sb!alien:define-alien-routine "unblock_gc_signals" 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
@@ -171,9 +179,13 @@
   (flet ((interrupt-it ()
            (with-alien ((context (* os-context-t) context))
              (with-interrupts
-               (%break 'sigint 'interactive-interrupt
-                       :context context
-                       :address (sap-int (sb!vm:context-pc context)))))))
+               (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)))
 
@@ -184,8 +196,7 @@
 
 (defun sigterm-handler (signal code context)
   (declare (ignore signal code context))
-  (sb!thread::terminate-session)
-  (sb!ext:quit))
+  (sb!ext:exit))
 
 ;;; SIGPIPE is not used in SBCL for its original purpose, instead it's
 ;;; for signalling a thread that it should look at its interruption
@@ -196,6 +207,11 @@
   (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."
@@ -210,6 +226,7 @@
   (enable-interrupt sigsys #'sigsys-handler)
   (enable-interrupt sigalrm #'sigalrm-handler)
   (enable-interrupt sigpipe #'sigpipe-handler)
+  (enable-interrupt sigchld #'sigchld-handler)
   #!+hpux (ignore-interrupt sigxcpu)
   (unblock-gc-signals)
   (unblock-deferrable-signals)