X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fsignal.lisp;h=945f77cc479c57329bdf9da5d8b8f79890a36295;hb=82cd148d729c241e79c8df04b700beec1b7c55de;hp=4205bf171438f047a592dfcd28d827288df27f67;hpb=08307967c71c580058a503d46aa087cfefcf8c69;p=sbcl.git diff --git a/src/code/signal.lisp b/src/code/signal.lisp index 4205bf1..945f77c 100644 --- a/src/code/signal.lisp +++ b/src/code/signal.lisp @@ -36,175 +36,163 @@ ;;; any system calls, and by then the cost of the extra system calls ;;; are lost in the noise when compared with the cost of delivering ;;; the signal in the first place. +;;; +;;; The conditional bindings done by this code here are worth the +;;; trouble as binding is more expensive then read & test -- so +;;; (if *foo* +;;; (foo) +;;; (let ((*foo* t)) +;;; (foo))) +;;; is faster then +;;; (let ((*foo* t)) +;;; (foo)) +;;; provided that the first branch is true "often enough". (defvar *interrupts-enabled* t) (defvar *interrupt-pending* nil) +#!+sb-thruption (defvar *thruption-pending* nil) +(defvar *allow-with-interrupts* t) +;;; This is to support signal handlers that want to return to the +;;; interrupted context without leaving anything extra on the stack. A +;;; simple +;;; +;;; (without-interrupts +;;; (unblock-deferrable-signals) +;;; (allow-with-interrupts ...)) +;;; +;;; would not cut it, as upon leaving WITHOUT-INTERRUPTS the pending +;;; handlers is run with stuff from the function in which this is +;;; still on the stack. +(defvar *unblock-deferrables-on-enabling-interrupts-p* nil) (sb!xc:defmacro without-interrupts (&body body) #!+sb-doc - "Execute BODY in a context impervious to interrupts." - (let ((name (gensym))) - `(flet ((,name () ,@body)) + "Executes BODY with all deferrable interrupts disabled. Deferrable +interrupts arriving during execution of the BODY take effect after BODY has +been executed. + +Deferrable interrupts include most blockable POSIX signals, and +SB-THREAD:INTERRUPT-THREAD. Does not interfere with garbage collection, and +unlike in many traditional Lisps using userspace threads, in SBCL +WITHOUT-INTERRUPTS does not inhibit scheduling of other threads. + +Binds ALLOW-WITH-INTERRUPTS and WITH-LOCAL-INTERRUPTS as a local macros. + +ALLOW-WITH-INTERRUPTS allows the WITH-INTERRUPTS to take effect during the +dynamic scope of its body, unless there is an outer WITHOUT-INTERRUPTS without +a corresponding ALLOW-WITH-INTERRUPTS. + +WITH-LOCAL-INTERRUPTS executes its body with interrupts enabled provided that +for there is an ALLOW-WITH-INTERRUPTS for every WITHOUT-INTERRUPTS surrounding +the current one. WITH-LOCAL-INTERRUPTS is equivalent to: + + (allow-with-interrupts (with-interrupts ...)) + +Care must be taken not to let either ALLOW-WITH-INTERRUPTS or +WITH-LOCAL-INTERRUPTS appear in a function that escapes from inside the +WITHOUT-INTERRUPTS in: + + (without-interrupts + ;; The body of the lambda would be executed with WITH-INTERRUPTS allowed + ;; regardless of the interrupt policy in effect when it is called. + (lambda () (allow-with-interrupts ...))) + + (without-interrupts + ;; The body of the lambda would be executed with interrupts enabled + ;; regardless of the interrupt policy in effect when it is called. + (lambda () (with-local-interrupts ...))) +" + (with-unique-names (outer-allow-with-interrupts without-interrupts-body) + `(dx-flet ((,without-interrupts-body () + (declare (disable-package-locks allow-with-interrupts + with-local-interrupts)) + (macrolet + ((allow-with-interrupts + (&body allow-forms) + `(let ((*allow-with-interrupts* + ,',outer-allow-with-interrupts)) + ,@allow-forms)) + (with-local-interrupts + (&body with-forms) + `(let ((*allow-with-interrupts* + ,',outer-allow-with-interrupts) + (*interrupts-enabled* + ,',outer-allow-with-interrupts)) + (when ,',outer-allow-with-interrupts + (when *unblock-deferrables-on-enabling-interrupts-p* + (setq *unblock-deferrables-on-enabling-interrupts-p* + nil) + (sb!unix::unblock-deferrable-signals)) + (when (or *interrupt-pending* + #!+sb-thruption *thruption-pending*) + (receive-pending-interrupt))) + (locally ,@with-forms)))) + (let ((*interrupts-enabled* nil) + (,outer-allow-with-interrupts *allow-with-interrupts*) + (*allow-with-interrupts* nil)) + (declare (ignorable ,outer-allow-with-interrupts)) + (declare (enable-package-locks allow-with-interrupts + with-local-interrupts)) + ,@body)))) (if *interrupts-enabled* - (unwind-protect - (let ((*interrupts-enabled* nil)) - (,name)) - ;; FIXME: Does it matter that an interrupt coming in here - ;; could be executed before any of the pending interrupts? - ;; Or do incoming interrupts have the good grace to check - ;; whether interrupts are pending before executing themselves - ;; immediately? - (when *interrupt-pending* - (receive-pending-interrupt))) - (,name))))) + (unwind-protect + (,without-interrupts-body) + ;; If we were interrupted in the protected section, + ;; then the interrupts are still blocked and it remains + ;; so until the pending interrupt is handled. + ;; + ;; If we were not interrupted in the protected section, + ;; but here, then even if the interrupt handler enters + ;; another WITHOUT-INTERRUPTS, the pending interrupt will be + ;; handled immediately upon exit from said + ;; WITHOUT-INTERRUPTS, so it is as if nothing has happened. + (when (or *interrupt-pending* + #!+sb-thruption *thruption-pending*) + (receive-pending-interrupt))) + (,without-interrupts-body))))) (sb!xc:defmacro with-interrupts (&body body) #!+sb-doc - "Allow interrupts while executing BODY. As interrupts are normally allowed, - this is only useful inside a WITHOUT-INTERRUPTS." - (let ((name (gensym))) - `(flet ((,name () ,@body)) - (if *interrupts-enabled* - (,name) - (let ((*interrupts-enabled* t)) - (when *interrupt-pending* - (receive-pending-interrupt)) - (,name)))))) - -;;;; utilities for dealing with signal names and numbers - -(defstruct (unix-signal - (:constructor make-unix-signal (%name %number)) - (:copier nil)) - ;; signal keyword (e.g. :SIGINT for the Unix SIGINT signal) - (%name (missing-arg) :type keyword :read-only t) - ;; signal number - (%number (missing-arg) :type integer :read-only t)) - -;;; list of all defined UNIX-SIGNALs -(defvar *unix-signals* nil) - -(defmacro !def-unix-signal (name number) - (declare (type keyword name)) - (declare (type (and fixnum unsigned-byte) number)) - `(push (make-unix-signal ,name ,number) *unix-signals*)) - -(/show0 "signal.lisp 131") - -(defun unix-signal-or-lose (designator) - (or (find designator (the list *unix-signals*) - :key (etypecase designator - (symbol #'unix-signal-%name) - (number #'unix-signal-%number))) - (error "not a valid signal name or number: ~S" designator))) - -(/show0 "signal.lisp 142") - -;;; Return the name of the designated signal. -(defun unix-signal-name (designator) - (symbol-name (unix-signal-%name (unix-signal-or-lose designator)))) - -(/show0 "signal.lisp 150") - -;;; Return the number of the designated signal. -(defun unix-signal-number (designator) - (unix-signal-%number (unix-signal-or-lose designator))) - -(/show0 "signal.lisp 168") - -;;; known signals -(/show0 "defining Unix signals") -(!def-unix-signal :CHECK 0) ; check -(/show0 "done defining CHECK") -(!def-unix-signal :SIGHUP 1) ; hangup -(/show0 "done defining SIGHUP") -(!def-unix-signal :SIGINT 2) ; interrupt -(/show0 "done defining SIGINT") -(!def-unix-signal :SIGQUIT 3) ; quit -(!def-unix-signal :SIGILL 4) ; illegal instruction -(!def-unix-signal :SIGTRAP 5) ; trace trap -(!def-unix-signal :SIGIOT 6) ; IOT instruction -#!-linux -(!def-unix-signal :SIGEMT 7) ; EMT instruction -(!def-unix-signal :SIGFPE 8) ; floating point exception -(!def-unix-signal :SIGKILL 9) ; kill -(!def-unix-signal :SIGBUS #!-linux 10 #!+linux 7) ; bus error -(!def-unix-signal :SIGSEGV 11) ; segmentation violation -#!-linux -(!def-unix-signal :SIGSYS 12) ; bad argument to system call -(!def-unix-signal :SIGPIPE 13) ; write on a pipe with no one to read it -(!def-unix-signal :SIGALRM 14) ; alarm clock -(!def-unix-signal :SIGTERM 15) ; software termination signal -#!+linux -(!def-unix-signal :SIGSTKFLT 16) ; stack fault on coprocessor -(!def-unix-signal :SIGURG ; urgent condition present on socket - #!+svr4 21 - #!-(or hpux svr4 linux) 16 - #!+hpux 29 - #!+linux 23) -(!def-unix-signal :SIGSTOP ; stop - #!-(or hpux svr4 linux) 17 - #!+hpux 24 - #!+svr4 23 - #!+linux 19) -(!def-unix-signal :SIGTSTP ; stop signal generated from keyboard - #!-(or hpux svr4 linux) 18 - #!+hpux 25 - #!+svr4 24 - #!+linux 20) -(!def-unix-signal :SIGCONT ; continue after stop - #!-(or hpux svr4 linux) 19 - #!+hpux 26 - #!+svr4 25 - #!+linux 18) -(!def-unix-signal :SIGCHLD ; Child status has changed. - #!-(or linux hpux) 20 - #!+hpux 18 - #!+linux 17) -(!def-unix-signal :SIGTTIN ; background read attempted from control terminal - #!-(or hpux svr4) 21 - #!+hpux 27 - #!+svr4 26) -(!def-unix-signal :SIGTTOU ; background write attempted to control terminal - #!-(or hpux svr4) 22 - #!+hpux 28 - #!+svr4 27) -(!def-unix-signal :SIGIO ; I/O is possible on a descriptor. - #!-(or hpux irix linux) 23 - #!+(or hpux irix) 22 - #!+linux 29) -#!-hpux -(!def-unix-signal :SIGXCPU ; CPU time limit exceeded - #!-svr4 24 - #!+svr4 30) -#!-hpux -(!def-unix-signal :SIGXFSZ ; file size limit exceeded - #!-svr4 25 - #!+svr4 31) -(!def-unix-signal :SIGVTALRM ; virtual time alarm - #!-(or hpux svr4) 26 - #!+hpux 20 - #!+svr4 28) -(!def-unix-signal :SIGPROF ; profiling timer alarm - #!-(or hpux svr4 linux) 27 - #!+hpux 21 - #!+svr4 29 - #!+linux 30) -(!def-unix-signal :SIGWINCH ; window size change - #!-(or hpux svr4) 28 - #!+hpux 23 - #!+svr4 20) -(!def-unix-signal :SIGUSR1 ; user-defined signal 1 - #!-(or hpux svr4 linux) 30 - #!+(or hpux svr4) 16 - #!+linux 10) -(!def-unix-signal :SIGUSR2 ; user-defined signal 2 - #!-(or hpux svr4 linux) 31 - #!+(or hpux svr4) 17 - #!+linux 12) - -;;; SVR4 (or Solaris?) specific signals -#!+svr4 -(!def-unix-signal :SIGWAITING 32) ; Process's LWPs are blocked. - -(/show0 "done with signal.lisp") + "Executes BODY with deferrable interrupts conditionally enabled. If there +are pending interrupts they take effect prior to executing BODY. + +As interrupts are normally allowed WITH-INTERRUPTS only makes sense if there +is an outer WITHOUT-INTERRUPTS with a corresponding ALLOW-WITH-INTERRUPTS: +interrupts are not enabled if any outer WITHOUT-INTERRUPTS is not accompanied +by ALLOW-WITH-INTERRUPTS." + (with-unique-names (allowp enablep) + ;; We could manage without ENABLEP here, but that would require + ;; taking extra care not to ever have *ALLOW-WITH-INTERRUPTS* NIL + ;; and *INTERRUPTS-ENABLED* T -- instead of risking future breakage + ;; we take the tiny hit here. + `(let* ((,allowp *allow-with-interrupts*) + (,enablep *interrupts-enabled*) + (*interrupts-enabled* (or ,enablep ,allowp))) + (when (and ,allowp (not ,enablep)) + (when *unblock-deferrables-on-enabling-interrupts-p* + (setq *unblock-deferrables-on-enabling-interrupts-p* nil) + (sb!unix::unblock-deferrable-signals)) + (when (or *interrupt-pending* + #!+sb-thruption *thruption-pending*) + (receive-pending-interrupt))) + (locally ,@body)))) + +(defmacro allow-with-interrupts (&body body) + (declare (ignore body)) + (error "~S is valid only inside ~S." + 'allow-with-interrupts 'without-interrupts)) + +(defmacro with-local-interrupts (&body body) + (declare (ignore body)) + (error "~S is valid only inside ~S." + 'with-local-interrupts 'without-interrupts)) + +;;; A low-level operation that assumes that *INTERRUPTS-ENABLED* is +;;; false, *ALLOW-WITH-INTERRUPTS* is true and deferrable signals are +;;; unblocked. +(defun %check-interrupts () + ;; Here we check for pending interrupts first, because reading a + ;; special is faster then binding it! + (when (or *interrupt-pending* #!+sb-thruption *thruption-pending*) + (let ((*interrupts-enabled* t)) + (receive-pending-interrupt))))