X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ftarget-signal.lisp;h=9fab9d171d263a6b5dd348463c1214474883f1d2;hb=ed1910efb36f71b5ebe33b5ffffd7195e15644de;hp=b660735a499c83a7222b099f554194b5e498f817;hpb=cf507f95509a855a752b6f1771aa06877b8a3b30;p=sbcl.git diff --git a/src/code/target-signal.lisp b/src/code/target-signal.lisp index b660735..9fab9d1 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 @@ -105,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) @@ -113,6 +108,7 @@ (defun unblock-deferrable-signals () (%unblock-deferrable-signals 0 0)) +#!-sb-safepoint (defun unblock-gc-signals () (%unblock-gc-signals 0 0)) @@ -185,12 +181,33 @@ (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-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)) @@ -198,9 +215,9 @@ (defun sigterm-handler (signal code context) (declare (ignore signal code context)) - (sb!thread::terminate-session) - (sb!ext:quit)) + (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 @@ -210,6 +227,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." @@ -222,10 +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))