(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)
(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)))))))))
+ (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))))))))))
(defmacro in-interruption ((&key) &body body)
#!+sb-doc
;;; 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))
\f
;;;; C routines that actually do all the work of establishing signal handlers
#!-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")
(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)))
(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."
(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)
(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)
projects / sbcl.git / blobdiff