X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fsignal.lisp;h=d6c7eee4b41e502b8daf6bc564e3c961bcd7c27e;hb=2db410feb35e7e30c95af8f20f67e6177fa92488;hp=a7db12d1872e67ac35a323294871894088851d1b;hpb=911adc876f0c319ccd612d8ad563d3c215aa3de1;p=sbcl.git diff --git a/src/code/signal.lisp b/src/code/signal.lisp index a7db12d..d6c7eee 100644 --- a/src/code/signal.lisp +++ b/src/code/signal.lisp @@ -89,48 +89,39 @@ WITHOUT-INTERRUPTS in: ;; regardless of the interrupt policy in effect when it is called. (lambda () (with-local-interrupts ...))) " - (with-unique-names (outer-allow-with-interrupts) - `(call-with-dx-function (call-without-interrupts - ,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) - `(call-allowing-with-interrupts - (lambda () ,@allow-forms) - ,',outer-allow-with-interrupts)) - (with-local-interrupts (&body with-forms) - `(call-with-local-interrupts - (lambda () ,@with-forms) - ,',outer-allow-with-interrupts))) - (declare (enable-package-locks allow-with-interrupts with-interrupts)) - ,@body)))) - -;;; Helper for making the DX closure allocation in WITHOUT-INTERRUPTS -;;; less ugly. -;;; -;;; TODO: generalize for cases where FUNCTION takes more arguments -;;; than just the thunk; use in other WITH-FOO macros that expand to a -;;; CALL-WITH-FOO. I just did WITHOUT-INTERRUPTS since it's -;;; performance critical (for example each call to GETHASH was consing -;;; 48 bytes of WITHOUT-INTERRUPTS closures). --JES, 2007-06-08 -(sb!xc:defmacro call-with-dx-function ((function &rest args) &body body) - (with-unique-names (fun1 fun2) - `(flet ((,fun1 (,@args) - ,@body)) - (declare (optimize sb!c::stack-allocate-dynamic-extent)) - (flet ((,fun2 (,@args) - ;; Avoid consing up a closure: FUN1 will be inlined - ;; and FUN2 will be stack-allocated, so we avoid - ;; consing up a closure. This is split into two - ;; separate functions to ensure that the body doesn't - ;; get compiled with (OPTIMIZE - ;; SB!C::STACK-ALLOCATE-DYNAMIC-EXTENT), which could - ;; cause problems e.g. when the body contains - ;; DYNAMIC-EXTENT declarations and the code is being - ;; compiled with (SAFETY 3). - (,fun1 ,@args))) - (declare (dynamic-extent (function ,fun2))) - (,function (function ,fun2)))))) + (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 + (,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 *interrupt-pending* + (receive-pending-interrupt))) + (,without-interrupts-body))))) (sb!xc:defmacro with-interrupts (&body body) #!+sb-doc @@ -141,61 +132,25 @@ 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." - `(call-with-interrupts - (lambda () ,@body) - (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)))) + (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.