src/code/target-exception.lisp

   1 ;;;; code for handling Win32 exceptions
   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!WIN32")
  13
  14 ;;;
  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.
  18 ;;;
  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.
  21 ;;;
  22 \f
  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).
  27 ;;;
  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).
  34 ;;;
  35 ;;; This specific bit of functionality may well be implemented entirely
  36 ;;; in the runtime.
  37 #||
  38 (defun sigint-%break (format-string &rest format-arguments)
  39   (flet ((break-it ()
  40            (apply #'%break 'sigint format-string format-arguments)))
  41     (sb!thread:interrupt-thread (sb!thread::foreground-thread) #'break-it)))
  42 ||#
  43 \f
  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))))))
  48     (list
  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)
  57      ;; Stack overflow
  58      (cons +exception-stack-overflow+        'sb!kernel::control-stack-exhausted)
  59      ;; Various
  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+))))
  73
  74 (define-alien-type ()
  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)))
  82
  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))))
  91     (if condition-name
  92         (error condition-name)
  93         (error "An exception occurred in context ~S: ~S. (Exception code: ~S)"
  94                context-sap exception-record-sap code))))
  95 \f
  96 ;;;; etc.
  97
  98 ;;; CMU CL comment:
  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))
 104
 105 (in-package "SB!UNIX")
 106
 107 #!+sb-thread
 108 (progn
 109   (defun receive-pending-interrupt ()
 110     (receive-pending-interrupt))
 111
 112   (defmacro with-interrupt-bindings (&body body)
 113     `(let*
 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
 119          ;; hit.
 120          ((sb!pcl::*cache-miss-values-stack* nil)
 121           (sb!pcl::*dfun-miss-gfs-on-stack* nil))
 122        ,@body))
 123
 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))
 128          (without-interrupts
 129            (unwind-protect
 130                 (progn
 131                   (allow-with-interrupts
 132                     ,protected-form)
 133                   (setq ,completep t))
 134              (unless ,completep
 135                ,@cleanup-froms))))))
 136
 137   (declaim (inline %unblock-deferrable-signals))
 138   (sb!alien:define-alien-routine ("unblock_deferrable_signals"
 139                                   %unblock-deferrable-signals)
 140       sb!alien:void
 141     (where sb!alien:unsigned)
 142     (old sb!alien:unsigned))
 143
 144   (defun block-deferrable-signals ()
 145     (%block-deferrable-signals 0 0))
 146
 147   (defun unblock-deferrable-signals ()
 148     (%unblock-deferrable-signals 0 0))
 149
 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)
 153       sb!alien:unsigned)
 154   (sb!alien:define-alien-routine ("apply_sigmask"
 155                                   %apply-sigmask)
 156       sb!alien:void
 157     (mask sb!alien:unsigned))
 158
 159   (defmacro without-interrupts/with-deferrables-blocked (&body body)
 160     (let ((mask-var (gensym)))
 161       `(without-interrupts
 162          (let ((,mask-var (%block-deferrables-and-return-mask)))
 163            (unwind-protect
 164                 (progn ,@body)
 165              (%apply-sigmask ,mask-var))))))
 166
 167   (defun invoke-interruption (function)
 168     (without-interrupts
 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
 180               (nlx-protect
 181                (funcall function)
 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)))))))))
 192
 193   (defmacro in-interruption ((&key) &body body)
 194     #!+sb-doc
 195     "Convenience macro on top of INVOKE-INTERRUPTION."
 196     `(dx-flet ((interruption () ,@body))
 197        (invoke-interruption #'interruption)))
 198
 199   (defun sb!kernel:signal-cold-init-or-reinit ()
 200     #!+sb-doc
 201     "Enable all the default signals that Lisp knows how to deal with."
 202     (unblock-deferrable-signals)
 203     (values)))