X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fsignal.lisp;h=02a215af07f92c5992aed74dad2b8631cc1a4012;hb=60a7d6fe1a3005f89973181c065d2bfa8c974e55;hp=5978b251315e1b3ed01db71ac4caca132e20b4df;hpb=978981c25c3834d034908762963d289e8ea9bb59;p=sbcl.git diff --git a/src/code/signal.lisp b/src/code/signal.lisp index 5978b25..02a215a 100644 --- a/src/code/signal.lisp +++ b/src/code/signal.lisp @@ -23,203 +23,165 @@ ;;; sets *interrupt-pending* and returns without handling the signal. ;;; ;;; When we drop out the without interrupts, we check to see whether -;;; *interrupt-pending* has been set. If so, we call -;;; do-pending-interrupt, which generates a SIGTRAP. The C code +;;; *INTERRUPT-PENDING* has been set. If so, we call +;;; RECEIVE-PENDING-INTERRUPT, which generates a SIGTRAP. The C code ;;; invokes the handler for the saved signal instead of the SIGTRAP ;;; after replacing the signal mask in the signal context with the ;;; saved value. When that hander returns, the original signal mask is ;;; installed, allowing any other pending signals to be handled. ;;; -;;; This means that the cost of without-interrupts is just a special +;;; This means that the cost of WITHOUT-INTERRUPTS is just a special ;;; binding in the case when no signals are delivered (the normal ;;; case). It's only when a signal is actually delivered that we use ;;; 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. - -;;; Magically converted by the compiler into a break instruction. -(defun do-pending-interrupt () - (do-pending-interrupt)) - -#!-gengc (progn +;;; +;;; 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) +(defvar *allow-with-interrupts* t) (sb!xc:defmacro without-interrupts (&body body) #!+sb-doc - "Execute BODY in a context impervious to interrupts." - (let ((name (gensym))) - `(flet ((,name () ,@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* - (do-pending-interrupt))) - (,name))))) + "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) + `(dx-flet ((without-interrupts-thunk (,outer-allow-with-interrupts) + (declare (disable-package-locks allow-with-interrupts + with-interrupts) + (ignorable ,outer-allow-with-interrupts)) + (macrolet ((allow-with-interrupts (&body allow-forms) + `(dx-flet ((allow-with-interrupts-thunk () + ,@allow-forms)) + (call-allowing-with-interrupts + #'allow-with-interrupts-thunk + ,',outer-allow-with-interrupts))) + (with-local-interrupts (&body with-forms) + `(dx-flet ((with-local-interrupts-thunk () + ,@with-forms)) + (call-with-local-interrupts + #'with-local-interrupts-thunk + ,',outer-allow-with-interrupts)))) + (declare (enable-package-locks allow-with-interrupts + with-interrupts)) + ,@body))) + (call-without-interrupts #'without-interrupts-thunk)))) (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* - (do-pending-interrupt)) - (,name)))))) - -) ; PROGN - -;;; On the GENGC system, we have to do it slightly differently because of the -;;; existence of threads. Each thread has a suspends_disabled_count in its -;;; mutator structure. When this value is other then zero, the low level stuff -;;; will not suspend the thread, but will instead set the suspend_pending flag -;;; (also in the mutator). So when we finish the without-interrupts, we just -;;; check the suspend_pending flag and trigger a do-pending-interrupt if -;;; necessary. - -#!+gengc -(defmacro without-interrupts (&body body) - `(unwind-protect - (progn - (locally - (declare (optimize (speed 3) (safety 0))) - (incf (sb!kernel:mutator-interrupts-disabled-count))) - ,@body) - (locally - (declare (optimize (speed 3) (safety 0))) - (when (and (zerop (decf (sb!kernel:mutator-interrupts-disabled-count))) - (not (zerop (sb!kernel:mutator-interrupt-pending)))) - (do-pending-interrupt))))) - -;;;; utilities for dealing with signal names and numbers - -(defstruct (unix-signal - (:constructor make-unix-signal (%name %number %description))) - %name ; signal keyword - (%number nil :type integer) ; UNIX signal number - (%description nil :type string)) ; documentation - -(defvar *unix-signals* nil - #!+sb-doc - "A list of Unix signal structures.") - -(defmacro def-unix-signal (name number description) - (let ((symbol (intern (symbol-name name)))) - `(progn - ;; KLUDGE: This PUSH should be probably be something like PUSHNEW if we - ;; want to be able to cleanly reload this file. (Or perhaps - ;; *UNIX-SIGNALS* should be a hash table keyed by signal name, or a - ;; vector keyed by signal number?) - (push (make-unix-signal ,name ,number ,description) *unix-signals*) - ;; This is to make the new signal lookup stuff compatible with - ;; old code which expects the symbol with the same print name as - ;; our keywords to be a constant with a value equal to the signal - ;; number. - (defconstant ,symbol ,number ,description)))) - -(defun unix-signal-or-lose (arg) - (let ((signal (find arg *unix-signals* - :key (etypecase arg - (symbol #'unix-signal-%name) - (number #'unix-signal-%number))))) - (unless signal - (error "~S is not a valid signal name or number." arg)) - signal)) - -(defun unix-signal-name (signal) - #!+sb-doc - "Return the name of the signal as a string. Signal should be a valid - signal number or a keyword of the standard UNIX signal name." - (symbol-name (unix-signal-%name (unix-signal-or-lose signal)))) - -(defun unix-signal-description (signal) - #!+sb-doc - "Return a string describing signal. Signal should be a valid signal - number or a keyword of the standard UNIX signal name." - (unix-signal-%description (unix-signal-or-lose signal))) - -(defun unix-signal-number (signal) - #!+sb-doc - "Return the number of the given signal. Signal should be a valid - signal number or a keyword of the standard UNIX signal name." - (unix-signal-%number (unix-signal-or-lose signal))) - -;;; known signals -(def-unix-signal :CHECK 0 "Check") -(def-unix-signal :SIGHUP 1 "Hangup") -(def-unix-signal :SIGINT 2 "Interrupt") -(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 #!+svr4 21 #!-(or hpux svr4 linux) 16 #!+hpux 29 - #!+linux 23 "Urgent condition present on socket") -(def-unix-signal :SIGSTOP #!-(or hpux svr4 linux) 17 #!+hpux 24 #!+svr4 23 - #!+linux 19 "Stop") -(def-unix-signal :SIGTSTP #!-(or hpux svr4 linux) 18 #!+hpux 25 #!+svr4 24 - #!+linux 20 "Stop signal generated from keyboard") -(def-unix-signal :SIGCONT #!-(or hpux svr4 linux) 19 #!+hpux 26 #!+svr4 25 - #!+linux 18 "Continue after stop") -(def-unix-signal :SIGCHLD #!-(or linux hpux) 20 - #!+hpux 18 #!+linux 17 "Child status has changed") -(def-unix-signal :SIGTTIN #!-(or hpux svr4) 21 #!+hpux 27 #!+svr4 26 - "Background read attempted from control terminal") -(def-unix-signal :SIGTTOU #!-(or hpux svr4) 22 #!+hpux 28 #!+svr4 27 - "Background write attempted to control terminal") -(def-unix-signal :SIGIO #!-(or hpux irix linux) 23 #!+(or hpux irix) 22 - #!+linux 29 - "I/O is possible on a descriptor") -#!-hpux -(def-unix-signal :SIGXCPU #!-svr4 24 #!+svr4 30 "Cpu time limit exceeded") -#!-hpux -(def-unix-signal :SIGXFSZ #!-svr4 25 #!+svr4 31 "File size limit exceeded") -(def-unix-signal :SIGVTALRM #!-(or hpux svr4) 26 #!+hpux 20 #!+svr4 28 - "Virtual time alarm") -(def-unix-signal :SIGPROF #!-(or hpux svr4 linux) 27 #!+hpux 21 #!+svr4 29 - #!+linux 30 "Profiling timer alarm") -(def-unix-signal :SIGWINCH #!-(or hpux svr4) 28 #!+hpux 23 #!+svr4 20 - "Window size change") -(def-unix-signal :SIGUSR1 #!-(or hpux svr4 linux) 30 #!+(or hpux svr4) 16 - #!+linux 10 "User defined signal 1") -(def-unix-signal :SIGUSR2 #!-(or hpux svr4 linux) 31 #!+(or hpux svr4) 17 - #!+linux 12 "User defined signal 2") - -#!+mach -(def-unix-signal :SIGEMSG 30 "Mach Emergency message") -#!+mach -(def-unix-signal :SIGMSG 31 "Mach message") - -;;; SVR4 (or Solaris?) specific signals -#!+svr4 -(def-unix-signal :SIGWAITING 32 "Process's lwps are blocked") - -(sb!xc:defmacro sigmask (&rest signals) - #!+sb-doc - "Returns a mask given a set of signals." - (apply #'logior - (mapcar #'(lambda (signal) - (ash 1 (1- (unix-signal-number signal)))) - signals))) + "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." + `(dx-flet ((with-interrupts-thunk () ,@body)) + (call-with-interrupts + #'with-interrupts-thunk + (and (not *interrupts-enabled*) *allow-with-interrupts*)))) + +(defun call-allowing-with-interrupts (function allowp) + (declare (function function)) + (if allowp + (let ((*allow-with-interrupts* t)) + (funcall function)) + (funcall function))) + +(defun call-with-interrupts (function allowp) + (declare (function function)) + (if allowp + (let ((*interrupts-enabled* t)) + (when *interrupt-pending* + (receive-pending-interrupt)) + (funcall function)) + (funcall function))) + +;; Distinct from CALL-WITH-INTERRUPTS as it needs to bind both *A-W-I* +;; and *I-E*. +(defun call-with-local-interrupts (function allowp) + (declare (function function)) + (if allowp + (let* ((*allow-with-interrupts* t) + (*interrupts-enabled* t)) + (when *interrupt-pending* + (receive-pending-interrupt)) + (funcall function)) + (funcall function))) + +(defun call-without-interrupts (function) + (declare (function function)) + (flet ((run-without-interrupts () + (if *allow-with-interrupts* + (let ((*allow-with-interrupts* nil)) + (funcall function t)) + (funcall function nil)))) + (if *interrupts-enabled* + (unwind-protect + (let ((*interrupts-enabled* nil)) + (run-without-interrupts)) + ;; 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 *interrupt-pending* + (receive-pending-interrupt))) + (run-without-interrupts)))) + +;;; A low-level operation that assumes that *INTERRUPTS-ENABLED* is false, +;;; and *ALLOW-WITH-INTERRUPTS* is true. +(defun %check-interrupts () + ;; Here we check for pending interrupts first, because reading a special + ;; is faster then binding it! + (when *interrupt-pending* + (let ((*interrupts-enabled* t)) + (receive-pending-interrupt))))