;;; 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)))))
-\f
-;;;; utilities for dealing with signal names and numbers
-
-(defstruct (unix-signal
- (:constructor make-unix-signal (%name %number %description))
- (:copier nil))
- %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))))
projects / sbcl.git / blobdiff