X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fsignal.lisp;h=d6c7eee4b41e502b8daf6bc564e3c961bcd7c27e;hb=2db410feb35e7e30c95af8f20f67e6177fa92488;hp=cc2100728e4d1958aa48bfd253604c2a67591b30;hpb=fd324a9d981355d8bc10d2bd469cb54c4c9108fd;p=sbcl.git diff --git a/src/code/signal.lisp b/src/code/signal.lisp index cc21007..d6c7eee 100644 --- a/src/code/signal.lisp +++ b/src/code/signal.lisp @@ -36,59 +36,127 @@ ;;; 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) - -;;; KLUDGE: This tells INTERRUPT-THREAD that it is being invoked as an -;;; interruption, so that if the thread being interrupted is the -;;; current thread it knows to enable interrupts. INVOKE-INTERRUPTION -;;; binds it to T, and WITHOUT-INTERRUPTS binds it to NIL, so that if -;;; interrupts are disable between INTERRUPT-THREAD and this we don't -;;; accidentally re-enable them. -(defvar *in-interruption* nil) +(defvar *allow-with-interrupts* t) (sb!xc:defmacro without-interrupts (&body body) #!+sb-doc - "Execute BODY with all deferrable interrupts deferred. 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." - (let ((name (gensym "WITHOUT-INTERRUPTS-BODY-"))) - `(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) + `(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 (and ,',outer-allow-with-interrupts *interrupt-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) - (*in-interruption* nil)) - (,name)) - ;; If we were interrupted in the protected section, then - ;; the interrupts are still blocked and it remains so - ;; until the pending interrupt is handled. + (,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. + ;; 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))) - (,name))))) + (,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 SB-SYS:WITHOUT-INTERRUPTS. Signals a runtime -warning if used inside the dynamic countour of SB-SYS:WITHOUT-GCING." - (let ((name (gensym))) - `(flet ((,name () ,@body)) - (if *interrupts-enabled* - (,name) - (progn - (when sb!kernel:*gc-inhibit* - (warn "Re-enabling interrupts while GC is inhibited.")) - (let ((*interrupts-enabled* t)) - (when *interrupt-pending* - (receive-pending-interrupt)) - (,name))))))) + "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 (and ,allowp (not ,enablep)) *interrupt-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, +;;; 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))))