(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)))
\f
;;;; system calls that deal with signals
+;;; Send the signal SIGNAL to the process with process id PID. SIGNAL
+;;; should be a valid signal number
#!-sb-fluid (declaim (inline real-unix-kill))
-(sb!alien:define-alien-routine ("kill" real-unix-kill) sb!alien:int
+(sb!alien:define-alien-routine ("kill" unix-kill) sb!alien:int
(pid sb!alien:int)
(signal sb!alien:int))
-;;; Send the signal SIGNAL to the process with process id PID. SIGNAL
-;;; should be a valid signal number or a keyword of the standard UNIX
-;;; signal name.
-(defun unix-kill (pid signal)
- (real-unix-kill pid (unix-signal-number signal)))
-
+;;; Send the signal SIGNAL to the all the process in process group
+;;; PGRP. SIGNAL should be a valid signal number
#!-sb-fluid (declaim (inline real-unix-killpg))
-(sb!alien:define-alien-routine ("killpg" real-unix-killpg) sb!alien:int
+(sb!alien:define-alien-routine ("killpg" unix-killpg) sb!alien:int
(pgrp sb!alien:int)
(signal sb!alien:int))
-;;; Send the signal SIGNAL to the all the process in process group
-;;; PGRP. SIGNAL should be a valid signal number or a keyword of the
-;;; standard UNIX signal name.
-(defun unix-killpg (pgrp signal)
- (real-unix-killpg pgrp (unix-signal-number signal)))
-
-;;; Set the current set of masked signals (those being blocked from
+;;; Reset the current set of masked signals (those being blocked from
;;; delivery).
;;;
-;;; (Note: CMU CL had a SIGMASK operator to create masks, but since
-;;; SBCL only uses 0, we no longer support it. If you need it, you
-;;; can pull it out of the CMU CL sources, or the old SBCL sources;
-;;; but you might also consider doing things the SBCL way and moving
-;;; this kind of C-level work down to C wrapper functions.)
-#!-sunos
-(sb!alien:define-alien-routine ("sigsetmask" unix-sigsetmask)
- sb!alien:unsigned-long
- (mask sb!alien:unsigned-long))
+;;; (Note: CMU CL had a more general SIGSETMASK call and a SIGMASK
+;;; operator to create masks, but since we only ever reset to 0, we no
+;;; longer support it. If you need it, you can pull it out of the CMU
+;;; CL sources, or the old SBCL sources; but you might also consider
+;;; doing things the SBCL way and moving this kind of C-level work
+;;; down to C wrapper functions.)
+
+(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))
+
\f
;;;; 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))
-\f
+ (handler sb!alien:unsigned-long)
+ (synchronous boolean))
+
;;;; interface to enabling and disabling signal handlers
-(defun enable-interrupt (signal-designator handler)
- (declare (type (or function (member :default :ignore)) handler))
- (without-gcing
- (let ((result (install-handler (unix-signal-number signal-designator)
- (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 function (sb!kernel:make-lisp-obj result)))))))
+;;; 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))
+ (/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))
(defun ignore-interrupt (signal)
(enable-interrupt signal :ignore))
\f
+;;;; 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))
+
+\f
;;;; default LISP signal handlers
;;;;
;;;; Most of these just call ERROR to report the presence of the signal.
;;; *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!kernel::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 sigint #'sigint-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 sigemt #'sigemt-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 :sigalrm #'sigalrm-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))
\f
;;;; 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))
-\f
-;;; 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)))))))
-|#
projects / sbcl.git / blobdiff