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 +exception-access-violation+ 'memory-fault-error)
  62      #+x86-64
  63      (cons +exception-heap-corruption+ 'foreign-heap-corruption)
  64      (cons-name +exception-array-bounds-exceeded+)
  65      (cons-name +exception-breakpoint+)
  66      (cons-name +exception-datatype-misalignment+)
  67      (cons-name +exception-illegal-instruction+)
  68      (cons-name +exception-in-page-error+)
  69      (cons-name +exception-int-divide-by-zero+)
  70      (cons-name +exception-int-overflow+)
  71      (cons-name +exception-invalid-disposition+)
  72      (cons-name +exception-noncontinuable-exception+)
  73      (cons-name +exception-priv-instruction+))))
  74
  75 (define-alien-type ()
  76     (struct exception-record
  77             (exception-code dword)
  78             (exception-flags dword)
  79             (exception-record system-area-pointer)
  80             (exception-address system-area-pointer)
  81             (number-parameters dword)
  82             (exception-information (array system-area-pointer
  83                                           #.+exception-maximum-parameters+))))
  84
  85 ;;; DBG_PRINTEXCEPTION_C shouldn't be fatal, and even if it is related to
  86 ;;; something bad, better to print the message than just fail with no info
  87 (defun dbg-printexception-c (record)
  88   (when (= (slot record 'number-parameters) 2)
  89     ;; (sap-int (deref (slot record 'exception-information) 0)) =
  90     ;; length of string including 0-terminator
  91     (warn "DBG_PRINTEXCEPTION_C: ~a"
  92           (cast
  93            (sap-alien (deref (slot record 'exception-information) 1)
  94                       (* char))
  95            c-string))))
  96
  97 (defun dbg-printexception-wide-c (record)
  98   (when (= (slot record 'number-parameters) 4)
  99     ;; (sap-alien (deref (slot record 'exception-information) 3)) =
 100     ;; WideCharToMultiByte string
 101     (warn "DBG_PRINTEXCEPTION_WIDE_C: ~a"
 102           (cast
 103            (sap-alien (deref (slot record 'exception-information) 1)
 104                       (* char))
 105            system-string))))
 106
 107 (define-condition exception (error)
 108   ((code :initarg :code :reader exception-code)
 109    (context :initarg :context :reader exception-context)
 110    (record :initarg :record :reader exception-record))
 111   (:report (lambda (c s)
 112              (format s "An exception occurred in context ~S: ~S. (Exception code: ~S)"
 113                      (exception-context c)
 114                      (exception-record c)
 115                      (exception-code c)))))
 116
 117 ;;; Undocumented exception (STATUS_HEAP_CORRUPTION). Occurs when calling free()
 118 ;;; with a bad pointer and possibly other places. On 64-bit processes,
 119 ;;; frame-based handlers don't get a chance to handle this exception because the
 120 ;;; HeapSetInformation() option HeapEnableTerminationOnCorruption is enabled by
 121 ;;; default and cannot be disabled. For the sake of interactive development and
 122 ;;; error reporting, we special-case this exception in our vectored exception
 123 ;;; handler, otherwise the SBCL process would be abruptly terminated.
 124 #+x86-64
 125 (define-condition foreign-heap-corruption (error) ()
 126   (:report
 127    #.(format nil "A foreign heap corruption exception occurred. (Exception code: ~S)"
 128              +exception-heap-corruption+)))
 129
 130 ;;; Actual exception handler. We hit something the runtime doesn't
 131 ;;; want to or know how to deal with (that is, not a sigtrap or gc wp
 132 ;;; violation), so it calls us here.
 133 (defun sb-kernel:handle-win32-exception (context-sap exception-record-sap)
 134   (let* ((record (deref (sap-alien exception-record-sap (* (struct exception-record)))))
 135          (code (slot record 'exception-code))
 136          (condition-name (cdr (assoc code *exception-code-map*)))
 137          (sb-debug:*stack-top-hint* (sb-kernel:find-interrupted-frame)))
 138     (unwind-protect
 139          (cond ((stringp condition-name)
 140                 (error condition-name))
 141                ((and condition-name
 142                      (subtypep condition-name 'arithmetic-error))
 143                 (multiple-value-bind (op operands)
 144                     (sb-di::decode-arithmetic-error-operands context-sap)
 145                   ;; KLUDGE: FP errors from library functions reset
 146                   ;; the FPU control bits.
 147                   ;; This might enable some disabled exceptions, but
 148                   ;; since at least one exception is not disabled it's
 149                   ;; unlikely that disabling other exceptions is
 150                   ;; important.
 151                   (sb-vm::float-cold-init-or-reinit)
 152                   (error condition-name :operation op
 153                                         :operands operands)))
 154                ((eq condition-name 'memory-fault-error)
 155                 (error 'memory-fault-error :address
 156                        (sap-int (deref (slot record 'exception-information) 1))))
 157                (condition-name
 158                 (error condition-name))
 159                ((= code +dbg-printexception-c+)
 160                 (dbg-printexception-c record))
 161                ((= code +dbg-printexception-wide-c+)
 162                 (dbg-printexception-wide-c record))
 163                (t
 164                 (cerror "Return from the exception handler"
 165                         'exception :context context-sap :record exception-record-sap
 166                                    :code code)))
 167       (when (eql code +exception-stack-overflow+)
 168         ;; on the way out, reset win32's stack guard page.
 169         (alien-funcall (extern-alien "win32_reset_stack_overflow_guard_page"
 170                                      (function void)))))))
 171 \f
 172
 173 (in-package "SB-UNIX")
 174
 175 (defun sb-kernel:signal-cold-init-or-reinit ()
 176   "Enable all the default signals that Lisp knows how to deal with."
 177   (unblock-deferrable-signals)
 178   (values))