1.0.9.18: Instrument COMPUTE-CALLING-FRAME for non-x86 with /noshow0.
[sbcl.git] / src / code / signal.lisp
1 ;;;; handling UNIX signals
2
3 ;;;; This software is part of the SBCL system. See the README file for
4 ;;;; more information.
5 ;;;;
6 ;;;; This software is derived from the CMU CL system, which was
7 ;;;; written at Carnegie Mellon University and released into the
8 ;;;; public domain. The software is in the public domain and is
9 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
10 ;;;; files for more information.
11
12 (in-package "SB!UNIX")
13 \f
14 ;;;; macros for dynamically enabling and disabling signal handling
15
16 ;;; Notes on how the without-interrupts/with-interrupts stuff works:
17 ;;;
18 ;;; Before invoking the supplied handler for any of the signals that
19 ;;; can be blocked, the C interrupt support code checks to see whether
20 ;;; *interrupts-enabled* has been bound to NIL. If so, it saves the
21 ;;; signal number and the value of the signal mask (from the signal
22 ;;; context), sets the signal mask to block all blockable signals,
23 ;;; sets *interrupt-pending* and returns without handling the signal.
24 ;;;
25 ;;; When we drop out the without interrupts, we check to see whether
26 ;;; *INTERRUPT-PENDING* has been set. If so, we call
27 ;;; RECEIVE-PENDING-INTERRUPT, which generates a SIGTRAP. The C code
28 ;;; invokes the handler for the saved signal instead of the SIGTRAP
29 ;;; after replacing the signal mask in the signal context with the
30 ;;; saved value. When that hander returns, the original signal mask is
31 ;;; installed, allowing any other pending signals to be handled.
32 ;;;
33 ;;; This means that the cost of WITHOUT-INTERRUPTS is just a special
34 ;;; binding in the case when no signals are delivered (the normal
35 ;;; case). It's only when a signal is actually delivered that we use
36 ;;; any system calls, and by then the cost of the extra system calls
37 ;;; are lost in the noise when compared with the cost of delivering
38 ;;; the signal in the first place.
39 ;;;
40 ;;; The conditional bindings done by this code here are worth the
41 ;;; trouble as binding is more expensive then read & test -- so
42 ;;;  (if *foo*
43 ;;;      (foo)
44 ;;;      (let ((*foo* t))
45 ;;;        (foo)))
46 ;;; is faster then
47 ;;;  (let ((*foo* t))
48 ;;;    (foo))
49 ;;; provided that the first branch is true "often enough".
50
51 (defvar *interrupts-enabled* t)
52 (defvar *interrupt-pending* nil)
53 (defvar *allow-with-interrupts* t)
54
55 (sb!xc:defmacro without-interrupts (&body body)
56   #!+sb-doc
57   "Executes BODY with all deferrable interrupts disabled. Deferrable
58 interrupts arriving during execution of the BODY take effect after BODY has
59 been executed.
60
61 Deferrable interrupts include most blockable POSIX signals, and
62 SB-THREAD:INTERRUPT-THREAD. Does not interfere with garbage collection, and
63 unlike in many traditional Lisps using userspace threads, in SBCL
64 WITHOUT-INTERRUPTS does not inhibit scheduling of other threads.
65
66 Binds ALLOW-WITH-INTERRUPTS and WITH-LOCAL-INTERRUPTS as a local macros.
67
68 ALLOW-WITH-INTERRUPTS allows the WITH-INTERRUPTS to take effect during the
69 dynamic scope of its body, unless there is an outer WITHOUT-INTERRUPTS without
70 a corresponding ALLOW-WITH-INTERRUPTS.
71
72 WITH-LOCAL-INTERRUPTS executes its body with interrupts enabled provided that
73 for there is an ALLOW-WITH-INTERRUPTS for every WITHOUT-INTERRUPTS surrounding
74 the current one. WITH-LOCAL-INTERRUPTS is equivalent to:
75
76   (allow-with-interrupts (with-interrupts ...))
77
78 Care must be taken not to let either ALLOW-WITH-INTERRUPTS or
79 WITH-LOCAL-INTERRUPTS appear in a function that escapes from inside the
80 WITHOUT-INTERRUPTS in:
81
82   (without-interrupts
83     ;; The body of the lambda would be executed with WITH-INTERRUPTS allowed
84     ;; regardless of the interrupt policy in effect when it is called.
85     (lambda () (allow-with-interrupts ...)))
86
87   (without-interrupts
88     ;; The body of the lambda would be executed with interrupts enabled
89     ;; regardless of the interrupt policy in effect when it is called.
90     (lambda () (with-local-interrupts ...)))
91 "
92   (with-unique-names (outer-allow-with-interrupts)
93     `(dx-flet ((without-interrupts-thunk (,outer-allow-with-interrupts)
94                  (declare (disable-package-locks allow-with-interrupts
95                                                  with-interrupts)
96                           (ignorable ,outer-allow-with-interrupts))
97                  (macrolet ((allow-with-interrupts (&body allow-forms)
98                               `(dx-flet ((allow-with-interrupts-thunk ()
99                                             ,@allow-forms))
100                                  (call-allowing-with-interrupts
101                                   #'allow-with-interrupts-thunk
102                                   ,',outer-allow-with-interrupts)))
103                             (with-local-interrupts (&body with-forms)
104                               `(dx-flet ((with-local-interrupts-thunk ()
105                                            ,@with-forms))
106                                  (call-with-local-interrupts
107                                   #'with-local-interrupts-thunk
108                                   ,',outer-allow-with-interrupts))))
109                    (declare (enable-package-locks allow-with-interrupts
110                                                   with-interrupts))
111                    ,@body)))
112        (call-without-interrupts #'without-interrupts-thunk))))
113
114 (sb!xc:defmacro with-interrupts (&body body)
115   #!+sb-doc
116   "Executes BODY with deferrable interrupts conditionally enabled. If there
117 are pending interrupts they take effect prior to executing BODY.
118
119 As interrupts are normally allowed WITH-INTERRUPTS only makes sense if there
120 is an outer WITHOUT-INTERRUPTS with a corresponding ALLOW-WITH-INTERRUPTS:
121 interrupts are not enabled if any outer WITHOUT-INTERRUPTS is not accompanied
122 by ALLOW-WITH-INTERRUPTS."
123   `(dx-flet ((with-interrupts-thunk () ,@body))
124      (call-with-interrupts
125       #'with-interrupts-thunk
126       (and (not *interrupts-enabled*) *allow-with-interrupts*))))
127
128 (defun call-allowing-with-interrupts (function allowp)
129   (declare (function function))
130   (if allowp
131       (let ((*allow-with-interrupts* t))
132         (funcall function))
133       (funcall function)))
134
135 (defun call-with-interrupts (function allowp)
136   (declare (function function))
137   (if allowp
138       (let ((*interrupts-enabled* t))
139         (when *interrupt-pending*
140           (receive-pending-interrupt))
141         (funcall function))
142       (funcall function)))
143
144 ;; Distinct from CALL-WITH-INTERRUPTS as it needs to bind both *A-W-I*
145 ;; and *I-E*.
146 (defun call-with-local-interrupts (function allowp)
147   (declare (function function))
148   (if allowp
149       (let* ((*allow-with-interrupts* t)
150              (*interrupts-enabled* t))
151         (when *interrupt-pending*
152           (receive-pending-interrupt))
153         (funcall function))
154       (funcall function)))
155
156 (defun call-without-interrupts (function)
157   (declare (function function))
158   (flet ((run-without-interrupts ()
159            (if *allow-with-interrupts*
160                (let ((*allow-with-interrupts* nil))
161                  (funcall function t))
162                (funcall function nil))))
163     (if *interrupts-enabled*
164         (unwind-protect
165              (let ((*interrupts-enabled* nil))
166                (run-without-interrupts))
167           ;; If we were interrupted in the protected section, then the
168           ;; interrupts are still blocked and it remains so until the
169           ;; pending interrupt is handled.
170           ;;
171           ;; If we were not interrupted in the protected section, but
172           ;; here, then even if the interrupt handler enters another
173           ;; WITHOUT-INTERRUPTS, the pending interrupt will be handled
174           ;; immediately upon exit from said WITHOUT-INTERRUPTS, so it
175           ;; is as if nothing has happened.
176           (when *interrupt-pending*
177             (receive-pending-interrupt)))
178         (run-without-interrupts))))
179
180 ;;; A low-level operation that assumes that *INTERRUPTS-ENABLED* is false,
181 ;;; and *ALLOW-WITH-INTERRUPTS* is true.
182 (defun %check-interrupts ()
183   ;; Here we check for pending interrupts first, because reading a special
184   ;; is faster then binding it!
185   (when *interrupt-pending*
186     (let ((*interrupts-enabled* t))
187       (receive-pending-interrupt))))