X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ftarget-signal.lisp;h=d38076006297b1a92dd0b3251be1f4acd10b1789;hb=0c3bbfaa2286626a2d915c8810f690aefc702661;hp=cdcae59ec6aa156493746615793bae61058468e4;hpb=ce0a49644dce03ca07008e8073897e4ed7b247df;p=sbcl.git diff --git a/src/code/target-signal.lisp b/src/code/target-signal.lisp index cdcae59..d380760 100644 --- a/src/code/target-signal.lisp +++ b/src/code/target-signal.lisp @@ -11,9 +11,61 @@ (in-package "SB!UNIX") -;;; These should probably be somewhere, but I don't know where. -(defconstant sig_dfl 0) -(defconstant sig_ign 1) +(defmacro with-interrupt-bindings (&body 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 + ;; 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) + (sb!debug:*stack-top-hint* (or sb!debug:*stack-top-hint* 'invoke-interruption))) + (with-interrupt-bindings + (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 + "Convenience macro on top of INVOKE-INTERRUPTION." + `(dx-flet ((interruption () ,@body)) + (invoke-interruption #'interruption))) ;;;; system calls that deal with signals @@ -41,31 +93,68 @@ ;;; 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-safepoint +(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)) + +#!-sb-safepoint +(defun unblock-gc-signals () + (%unblock-gc-signals 0 0)) + ;;;; C routines that actually do all the work of establishing signal handlers (sb!alien:define-alien-routine ("install_handler" install-handler) - sb!alien:unsigned-long + sb!alien:unsigned-long (signal sb!alien:int) - (handler sb!alien:unsigned-long)) + (handler sb!alien:unsigned-long) + (synchronous boolean)) ;;;; interface to enabling and disabling signal handlers -(defun enable-interrupt (signal handler) +;;; Note on the SYNCHRONOUS argument: On builds without pseudo-atomic, +;;; we have no way of knowing whether interrupted code was in an +;;; allocation sequence, and cannot delay signals until after +;;; allocation. Any signal that can occur asynchronously must be +;;; considered unsafe for immediate execution, and the invocation of its +;;; lisp handler will get delayed into a newly spawned signal handler +;;; thread. However, there are signals which we must handle +;;; immediately, because they occur synchonously (hence the boolean flag +;;; SYNCHRONOUS to this function), luckily implying that the signal +;;; happens only in specific places (illegal instructions, floating +;;; point instructions, certain system calls), hopefully ruling out the +;;; possibility that we would trigger it during allocation. + +(defun enable-interrupt (signal handler &key synchronous) (declare (type (or function fixnum (member :default :ignore)) handler)) - (without-gcing - (let ((result (install-handler signal - (case handler - (:default sig_dfl) - (:ignore sig_ign) - (t - (sb!kernel:get-lisp-obj-address - handler)))))) - (cond ((= result sig_dfl) :default) - ((= result sig_ign) :ignore) - (t (the (or function fixnum) (sb!kernel:make-lisp-obj result))))))) + (/show0 "enable-interrupt") + (flet ((run-handler (&rest args) + (declare (truly-dynamic-extent args)) + (in-interruption () + (apply handler args)))) + (without-gcing + (let ((result (install-handler signal + (case handler + (:default sig-dfl) + (:ignore sig-ign) + (t + (sb!kernel:get-lisp-obj-address + #'run-handler))) + synchronous))) + (cond ((= result sig-dfl) :default) + ((= result sig-ign) :ignore) + (t (the (or function fixnum) + (sb!kernel:make-lisp-obj result)))))))) (defun default-interrupt (signal) (enable-interrupt signal :default)) @@ -73,6 +162,26 @@ (defun ignore-interrupt (signal) (enable-interrupt signal :ignore)) +;;;; Support for signal handlers which aren't. +;;;; +;;;; On safepoint builds, user-defined Lisp signal handlers do not run +;;;; in the handler for their signal, because we have no pseudo atomic +;;;; mechanism to prevent handlers from hitting during allocation. +;;;; Rather, the signal spawns off a fresh native thread, which calls +;;;; into lisp with a fake context through this callback: + +#!+(and sb-safepoint-strictly (not win32)) +(defun signal-handler-callback (run-handler signal args) + (sb!thread::initial-thread-function-trampoline + (sb!thread::make-signal-handling-thread :name "signal handler" + :signal-number signal) + nil (lambda () + (let* ((info (sb!sys:sap-ref-sap args 0)) + (context (sb!sys:sap-ref-sap args sb!vm:n-word-bytes))) + (funcall run-handler signal info context))) + nil nil nil nil)) + + ;;;; default LISP signal handlers ;;;; ;;;; Most of these just call ERROR to report the presence of the signal. @@ -81,92 +190,121 @@ ;;; *DEBUGGER-HOOK*, but we want SIGINT's BREAK to respect it, so that ;;; SIGINT in --disable-debugger mode will cleanly terminate the system ;;; (by respecting the *DEBUGGER-HOOK* established in that mode). -(defun sigint-%break (format-string &rest format-arguments) - (apply #'%break 'sigint format-string format-arguments)) - (eval-when (:compile-toplevel :execute) - (sb!xc:defmacro define-signal-handler (name - what - &optional (function 'error)) + (sb!xc:defmacro define-signal-handler (name what &optional (function 'error)) `(defun ,name (signal info context) (declare (ignore signal info)) (declare (type system-area-pointer context)) - (/show "in Lisp-level signal handler" (sap-int context)) - (,function ,(concatenate 'simple-string what " at #X~X") - (with-alien ((context (* os-context-t) context)) - (sap-int (sb!vm:context-pc context))))))) + (/show "in Lisp-level signal handler" ,(symbol-name name) + (sap-int context)) + (with-interrupts + (,function ,(concatenate 'simple-string what " at #X~X") + (with-alien ((context (* os-context-t) context)) + (sap-int (sb!vm:context-pc context)))))))) -(define-signal-handler sigint-handler "interrupted" sigint-%break) (define-signal-handler sigill-handler "illegal instruction") -(define-signal-handler sigtrap-handler "breakpoint/trap") -(define-signal-handler sigiot-handler "SIGIOT") #!-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") -(define-signal-handler sigpipe-handler "SIGPIPE") +(defun sigint-handler (signal info context) + (declare (ignore signal info)) + (declare (type system-area-pointer context)) + (/show "in Lisp-level SIGINT handler" (sap-int context)) + (flet ((interrupt-it () + ;; This seems wrong to me on multi-threaded builds. The + ;; closed-over signal context belongs to a SIGINT handler. + ;; But this function gets run through INTERRUPT-THREAD, + ;; i.e. in in a SIGPIPE handler, at a different point in time + ;; or even a different thread. How do we know that the + ;; SIGINT's context structure from the other thread is still + ;; alive and meaningful? Why do we care? If we even need + ;; the context and PC, shouldn't they come from the SIGPIPE's + ;; context? --DFL + (with-alien ((context (* os-context-t) 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-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)) - (cerror "Continue" 'sb!ext::timeout)) + (sb!impl::run-expired-timers)) + +(defun sigterm-handler (signal code context) + (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 +;;; 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)) -(defun sigquit-handler (signal code context) +;;; the handler for SIGCHLD signals for RUN-PROGRAM +(defun sigchld-handler (signal code context) (declare (ignore signal code context)) - (throw 'sb!impl::toplevel-catcher nil)) + (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 sigint #'sigint-handler) - (enable-interrupt sigquit #'sigquit-handler) - (enable-interrupt sigill #'sigill-handler) - (enable-interrupt sigtrap #'sigtrap-handler) - (enable-interrupt sigiot #'sigiot-handler) + (enable-interrupt sigterm #'sigterm-handler) + (enable-interrupt sigill #'sigill-handler :synchronous t) #!-linux (enable-interrupt sigemt #'sigemt-handler) - (enable-interrupt sigfpe #'sb!vm:sigfpe-handler) - (enable-interrupt sigbus #'sigbus-handler) - (enable-interrupt sigsegv #'sigsegv-handler) + (enable-interrupt sigfpe #'sb!vm:sigfpe-handler :synchronous t) + (enable-interrupt sigbus #'sigbus-handler :synchronous t) #!-linux - (enable-interrupt sigsys #'sigsys-handler) - (enable-interrupt sigpipe #'sigpipe-handler) + (enable-interrupt sigsys #'sigsys-handler :synchronous t) + #!-sb-wtimer (enable-interrupt sigalrm #'sigalrm-handler) + #!-sb-thruption + (enable-interrupt sigpipe #'sigpipe-handler) + (enable-interrupt sigchld #'sigchld-handler) + #!+hpux (ignore-interrupt sigxcpu) + #!-sb-safepoint (unblock-gc-signals) + (unblock-deferrable-signals) (values)) ;;;; etc. +;;; extract si_code from siginfo_t +(sb!alien:define-alien-routine ("siginfo_code" siginfo-code) sb!alien:int + (info system-area-pointer)) + ;;; CMU CL comment: ;;; Magically converted by the compiler into a break instruction. (defun receive-pending-interrupt () (receive-pending-interrupt)) - -;;; stale code which I'm insufficiently motivated to test -- WHN 19990714 -#| -;;;; WITH-ENABLED-INTERRUPTS - -(defmacro with-enabled-interrupts (interrupt-list &body body) - #!+sb-doc - "With-enabled-interrupts ({(interrupt function)}*) {form}* - Establish function as a handler for the Unix signal interrupt which - should be a number between 1 and 31 inclusive." - (let ((il (gensym)) - (it (gensym))) - `(let ((,il NIL)) - (unwind-protect - (progn - ,@(do* ((item interrupt-list (cdr item)) - (intr (caar item) (caar item)) - (ifcn (cadar item) (cadar item)) - (forms NIL)) - ((null item) (nreverse forms)) - (when (symbolp intr) - (setq intr (symbol-value intr))) - (push `(push `(,,intr ,(enable-interrupt ,intr ,ifcn)) ,il) - forms)) - ,@body) - (dolist (,it (nreverse ,il)) - (enable-interrupt (car ,it) (cadr ,it))))))) -|#