1 ;;;; code for handling Win32 exceptions
3 ;;;; This software is part of the SBCL system. See the README file for
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.
12 (in-package "SB!WIN32")
15 ;;; An awful lot of this stuff is stubbed out for now. We basically
16 ;;; only handle inbound exceptions (the local equivalent to unblockable
17 ;;; signals), and we're only picking off the sigsegv and sigfpe traps.
19 ;;; This file is based on target-signal.lisp, but most of that went
20 ;;; away. Some of it might want to be put back or emulated.
23 ;;; SIGINT is handled like BREAK, except that ANSI BREAK ignores
24 ;;; *DEBUGGER-HOOK*, but we want SIGINT's BREAK to respect it, so that
25 ;;; SIGINT in --disable-debugger mode will cleanly terminate the system
26 ;;; (by respecting the *DEBUGGER-HOOK* established in that mode).
28 ;;; We'd like to have this work, but that would require some method of
29 ;;; delivering a "blockable signal". Windows doesn't really have the
30 ;;; concept, so we need to play with the threading functions to emulate
31 ;;; it (especially since the local equivalent of SIGINT comes in on a
32 ;;; separate thread). This is on the list for fixing later on, and will
33 ;;; be required before we implement threads (because of stop-for-gc).
35 ;;; This specific bit of functionality may well be implemented entirely
38 (defun sigint-%break (format-string &rest format-arguments)
40 (apply #'%break 'sigint format-string format-arguments)))
41 (sb!thread:interrupt-thread (sb!thread::foreground-thread) #'break-it)))
44 ;;; Map Windows Exception code to condition names: symbols or strings
45 (defvar *exception-code-map*
46 (macrolet ((cons-name (symbol)
47 `(cons ,symbol ,(remove #\+ (substitute #\_ #\- (string symbol))))))
49 ;; Floating point exceptions
50 (cons +exception-flt-divide-by-zero+ 'division-by-zero)
51 (cons +exception-flt-invalid-operation+ 'floating-point-invalid-operation)
52 (cons +exception-flt-underflow+ 'floating-point-underflow)
53 (cons +exception-flt-overflow+ 'floating-point-overflow)
54 (cons +exception-flt-inexact-result+ 'floating-point-inexact)
55 (cons +exception-flt-denormal-operand+ 'floating-point-exception)
56 (cons +exception-flt-stack-check+ 'floating-point-exception)
58 (cons +exception-stack-overflow+ 'sb!kernel::control-stack-exhausted)
60 (cons-name +exception-single-step+)
61 (cons-name +exception-access-violation+) ; FIXME: should turn into MEMORY-FAULT-ERROR
62 ; plus the faulting address
63 (cons-name +exception-array-bounds-exceeded+)
64 (cons-name +exception-breakpoint+)
65 (cons-name +exception-datatype-misalignment+)
66 (cons-name +exception-illegal-instruction+)
67 (cons-name +exception-in-page-error+)
68 (cons-name +exception-int-divide-by-zero+)
69 (cons-name +exception-int-overflow+)
70 (cons-name +exception-invalid-disposition+)
71 (cons-name +exception-noncontinuable-exception+)
72 (cons-name +exception-priv-instruction+))))
75 (struct exception-record
76 (exception-code dword)
77 (exception-flags dword)
78 (exception-record system-area-pointer)
79 (exception-address system-area-pointer)
80 (number-parameters dword)
81 (exception-information system-area-pointer)))
83 ;;; Actual exception handler. We hit something the runtime doesn't
84 ;;; want to or know how to deal with (that is, not a sigtrap or gc wp
85 ;;; violation), so it calls us here.
86 (defun sb!kernel:handle-win32-exception (context-sap exception-record-sap)
87 (let* ((record (deref (sap-alien exception-record-sap (* (struct exception-record)))))
88 (code (slot record 'exception-code))
89 (condition-name (cdr (assoc code *exception-code-map*)))
90 (sb!debug:*stack-top-hint* (nth-value 1 (sb!kernel:find-interrupted-name-and-frame))))
92 (error condition-name)
93 (error "An exception occurred in context ~S: ~S. (Exception code: ~S)"
94 context-sap exception-record-sap code))))
99 ;;; Magically converted by the compiler into a break instruction.
100 ;;; SBCL/Win32 comment:
101 ;;; I don't know if we still need this or not. Better safe for now.
102 (defun receive-pending-interrupt ()
103 (receive-pending-interrupt))
105 (in-package "SB!UNIX")
109 (defun receive-pending-interrupt ()
110 (receive-pending-interrupt))
112 (defmacro with-interrupt-bindings (&body body)
114 ;; KLUDGE: Whatever is on the PCL stacks before the interrupt
115 ;; handler runs doesn't really matter, since we're not on the
116 ;; same call stack, really -- and if we don't bind these (esp.
117 ;; the cache one) we can get a bogus metacircle if an interrupt
118 ;; handler calls a GF that was being computed when the interrupt
120 ((sb!pcl::*cache-miss-values-stack* nil)
121 (sb!pcl::*dfun-miss-gfs-on-stack* nil))
124 ;;; Evaluate CLEANUP-FORMS iff PROTECTED-FORM does a non-local exit.
125 (defmacro nlx-protect (protected-form &rest cleanup-froms)
126 (with-unique-names (completep)
127 `(let ((,completep nil))
131 (allow-with-interrupts
135 ,@cleanup-froms))))))
137 (declaim (inline %unblock-deferrable-signals))
138 (sb!alien:define-alien-routine ("unblock_deferrable_signals"
139 %unblock-deferrable-signals)
141 (where sb!alien:unsigned)
142 (old sb!alien:unsigned))
144 (defun block-deferrable-signals ()
145 (%block-deferrable-signals 0 0))
147 (defun unblock-deferrable-signals ()
148 (%unblock-deferrable-signals 0 0))
150 (declaim (inline %block-deferrables-and-return-mask %apply-sigmask))
151 (sb!alien:define-alien-routine ("block_deferrables_and_return_mask"
152 %block-deferrables-and-return-mask)
154 (sb!alien:define-alien-routine ("apply_sigmask"
157 (mask sb!alien:unsigned))
159 (defmacro without-interrupts/with-deferrables-blocked (&body body)
160 (let ((mask-var (gensym)))
162 (let ((,mask-var (%block-deferrables-and-return-mask)))
165 (%apply-sigmask ,mask-var))))))
167 (defun invoke-interruption (function)
169 ;; Reset signal mask: the C-side handler has blocked all
170 ;; deferrable signals before funcalling into lisp. They are to be
171 ;; unblocked the first time interrupts are enabled. With this
172 ;; mechanism there are no extra frames on the stack from a
173 ;; previous signal handler when the next signal is delivered
174 ;; provided there is no WITH-INTERRUPTS.
175 (let ((sb!unix::*unblock-deferrables-on-enabling-interrupts-p* t))
176 (with-interrupt-bindings
177 (let ((sb!debug:*stack-top-hint*
178 (nth-value 1 (sb!kernel:find-interrupted-name-and-frame))))
179 (allow-with-interrupts
182 ;; We've been running with deferrables
183 ;; blocked in Lisp called by a C signal
184 ;; handler. If we return normally the sigmask
185 ;; in the interrupted context is restored.
186 ;; However, if we do an nlx the operating
187 ;; system will not restore it for us.
188 (when sb!unix::*unblock-deferrables-on-enabling-interrupts-p*
189 ;; This means that storms of interrupts
190 ;; doing an nlx can still run out of stack.
191 (unblock-deferrable-signals)))))))))
193 (defmacro in-interruption ((&key) &body body)
195 "Convenience macro on top of INVOKE-INTERRUPTION."
196 `(dx-flet ((interruption () ,@body))
197 (invoke-interruption #'interruption)))
199 (defun sb!kernel:signal-cold-init-or-reinit ()
201 "Enable all the default signals that Lisp knows how to deal with."
202 (unblock-deferrable-signals)