src/code/interr.lisp

   1 ;;;; functions and macros to define and deal with internal errors
   2 ;;;; (i.e. problems that can be signaled from assembler code)
   3
   4 ;;;; This software is part of the SBCL system. See the README file for
   5 ;;;; more information.
   6 ;;;;
   7 ;;;; This software is derived from the CMU CL system, which was
   8 ;;;; written at Carnegie Mellon University and released into the
   9 ;;;; public domain. The software is in the public domain and is
  10 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
  11 ;;;; files for more information.
  12
  13 (in-package "SB!KERNEL")
  14 \f
  15 ;;;; internal errors
  16
  17 (defvar *internal-errors*
  18   #.(map 'vector
  19          (lambda (x) (if (typep (car x) '(or symbol cons)) (car x) 0))
  20          sb!c:*backend-internal-errors*))
  21
  22 (eval-when (:compile-toplevel :execute)
  23 (sb!xc:defmacro deferr (name args &rest body)
  24   (let ((n (length args)))
  25     (unless (<= n 3)
  26       (error "Update (DEFUN INTERNAL-ERROR) for ~D error arguments" n)))
  27   `(progn
  28      (setf (svref *internal-errors* ,(error-number-or-lose name))
  29          (lambda (name ,@args)
  30            (declare (optimize (sb!c::verify-arg-count 0)) (ignorable name))
  31            ,@body))
  32      ;; general KLUDGE: refer to each error symbol. Can't just return ',NAME
  33      ;; - the compiler knows an effectless form when it sees one.
  34      (locally (declare (notinline string)) (string ',name))))
  35 ) ; EVAL-WHEN
  36
  37 ;; special KLUDGE for UNKNOWN-ERROR, which has no DEFERR at all
  38 (locally (declare (notinline string)) (string 'unknown-error))
  39
  40 (deferr undefined-fun-error (fdefn-or-symbol)
  41   (error 'undefined-function
  42          :name (etypecase fdefn-or-symbol
  43                  (symbol fdefn-or-symbol)
  44                  (fdefn (fdefn-name fdefn-or-symbol)))))
  45
  46 #!+(or arm x86-64)
  47 (deferr undefined-alien-fun-error (address)
  48   (error 'undefined-alien-function-error
  49          :name
  50          (and (integerp address)
  51               (sap-foreign-symbol (int-sap address)))))
  52
  53 #!-(or arm x86-64)
  54 (defun undefined-alien-fun-error ()
  55   (error 'undefined-alien-function-error))
  56
  57 (deferr invalid-arg-count-error (nargs &optional (fname nil fnamep))
  58   (if fnamep
  59       (error 'simple-program-error
  60          :format-control "~S called with invalid number of arguments: ~S"
  61          :format-arguments (list fname nargs))
  62       (error 'simple-program-error
  63              :format-control "invalid number of arguments: ~S"
  64              :format-arguments (list nargs))))
  65
  66 (deferr bogus-arg-to-values-list-error (list)
  67   (error 'simple-type-error
  68          :datum list
  69          :expected-type 'list
  70          :format-control
  71          "~@<attempt to use VALUES-LIST on a dotted list: ~2I~_~S~:>"
  72          :format-arguments (list list)))
  73
  74 (deferr unbound-symbol-error (symbol)
  75   (error 'unbound-variable :name symbol))
  76
  77 (deferr invalid-unwind-error ()
  78   (error 'simple-control-error
  79          :format-control
  80          "attempt to RETURN-FROM a block or GO to a tag that no longer exists"))
  81
  82 (deferr unseen-throw-tag-error (tag)
  83   (error 'simple-control-error
  84          :format-control "attempt to THROW to a tag that does not exist: ~S"
  85          :format-arguments (list tag)))
  86
  87 (deferr nil-fun-returned-error (function)
  88   (error 'simple-control-error
  89          :format-control
  90          "A function with declared result type NIL returned:~%  ~S"
  91          :format-arguments (list function)))
  92
  93 (deferr nil-array-accessed-error (array)
  94   (error 'nil-array-accessed-error
  95          :datum array :expected-type '(not (array nil))))
  96
  97 (deferr division-by-zero-error (this that)
  98   (error 'division-by-zero
  99          :operation '/
 100          :operands (list this that)))
 101
 102 (deferr object-not-type-error (object type)
 103   (if (invalid-array-p object)
 104       (invalid-array-error object)
 105       (error (if (and (%instancep object)
 106                       (layout-invalid (%instance-layout object)))
 107                  'layout-invalid
 108                  'type-error)
 109              :datum object
 110              :expected-type type)))
 111
 112 (deferr layout-invalid-error (object layout)
 113   (error 'layout-invalid
 114          :datum object
 115          :expected-type (layout-classoid layout)))
 116
 117 (deferr odd-key-args-error ()
 118   (error 'simple-program-error
 119          :format-control "odd number of &KEY arguments"))
 120
 121 (deferr unknown-key-arg-error (key-name)
 122   (error 'simple-program-error
 123          :format-control "unknown &KEY argument: ~S"
 124          :format-arguments (list key-name)))
 125
 126 ;; FIXME: missing (deferr wrong-number-of-indices)
 127 ;; we don't ever raise that error through a primitive trap I guess.
 128
 129 ;; TODO: make the arguments (ARRAY INDEX &optional BOUND)
 130 ;; and don't need the bound for vectors. Just read it.
 131 (deferr invalid-array-index-error (array bound index)
 132   (invalid-array-index-error array index bound))
 133
 134 (deferr tls-exhausted-error ()
 135   ;; There is nothing we can do about it. A number of entries in the
 136   ;; tls could be reserved and made available for recovery but since
 137   ;; tls indices are never reused it would be kind of silly and
 138   ;; without it signalling an error is more than likely to end in a
 139   ;; recursive error.
 140   (%primitive print "Thread local storage exhausted.")
 141   (sb!impl::%halt))
 142
 143 \f
 144 ;;;; fetching errorful function name
 145
 146 ;;; This flag is used to prevent infinite recursive lossage when
 147 ;;; we can't find the caller for some reason.
 148 (defvar *finding-name* nil)
 149
 150 (defun find-caller-name-and-frame ()
 151   (if *finding-name*
 152       (values "<error finding caller name -- already finding name>" nil)
 153       (handler-case
 154           (let* ((*finding-name* t)
 155                  (frame (sb!di:frame-down (sb!di:frame-down (sb!di:top-frame))))
 156                  (name (sb!di:debug-fun-name
 157                         (sb!di:frame-debug-fun frame))))
 158             (sb!di:flush-frames-above frame)
 159             (values name frame))
 160         (error ()
 161           (values "<error finding caller name -- trapped error>" nil))
 162         (sb!di:debug-condition ()
 163           (values "<error finding caller name -- trapped debug-condition>"
 164                   nil)))))
 165
 166 (defun find-interrupted-name-and-frame ()
 167   (/show0 "entering FIND-INTERRUPTED-NAME-AND-FRAME")
 168   (if *finding-name*
 169       (values "<error finding interrupted name -- already finding name>" nil)
 170       (handler-case
 171           (let ((*finding-name* t))
 172             (/show0 "in ordinary case")
 173             (do ((frame (sb!di:top-frame) (sb!di:frame-down frame)))
 174                 ((null frame)
 175                  (/show0 "null frame")
 176                  (values "<error finding interrupted name -- null frame>" nil))
 177               (/noshow0 "at head of DO loop")
 178               (when (and (sb!di::compiled-frame-p frame)
 179                          (sb!di::compiled-frame-escaped frame))
 180                 (sb!di:flush-frames-above frame)
 181                 (/show0 "returning from within DO loop")
 182                 (return (values (sb!di:debug-fun-name
 183                                  (sb!di:frame-debug-fun frame))
 184                                 frame)))))
 185         (error ()
 186           (/show0 "trapped ERROR")
 187           (values "<error finding interrupted name -- trapped error>" nil))
 188         (sb!di:debug-condition ()
 189           (/show0 "trapped DEBUG-CONDITION")
 190           (values "<error finding interrupted name -- trapped debug-condition>"
 191                   nil)))))
 192
 193 (defun find-caller-of-named-frame (name)
 194   (unless *finding-name*
 195     (handler-case
 196         (let ((*finding-name* t))
 197           (do ((frame (sb!di:top-frame) (sb!di:frame-down frame)))
 198               ((null frame))
 199             (when (and (sb!di::compiled-frame-p frame)
 200                        (eq name (sb!di:debug-fun-name
 201                                  (sb!di:frame-debug-fun frame))))
 202               (let ((caller (sb!di:frame-down frame)))
 203                 (sb!di:flush-frames-above caller)
 204                 (return caller)))))
 205       ((or error sb!di:debug-condition) ()
 206         nil)
 207       (sb!di:debug-condition ()
 208         nil))))
 209 \f
 210
 211 ;;; Returns true if number of arguments matches required/optional
 212 ;;; arguments handler expects.
 213 (defun internal-error-args-ok (arguments handler)
 214   (multiple-value-bind (llks req opt)
 215       (parse-lambda-list (%simple-fun-arglist handler) :silent t)
 216     (declare (ignore llks))
 217     ;; The handler always gets name as the first (extra) argument.
 218     (let ((n (1+ (length arguments)))
 219           (n-req (length req))
 220           (n-opt (length opt)))
 221       (and (>= n n-req) (<= n (+ n-req n-opt))))))
 222
 223 ;;;; INTERNAL-ERROR signal handler
 224
 225 ;;; Backtrace code may want to know the error that caused
 226 ;;; interruption, but there are other means to get code interrupted
 227 ;;; and inspecting code around PC for the error number may yield wrong
 228 ;;; results.
 229 (defvar *current-internal-error* nil)
 230
 231 ;;; This is needed for restarting XEPs, which do not bind anything but
 232 ;;; also do not save their own BSP, and we need to discard the
 233 ;;; bindings made by the error handling machinery.
 234 #!+unwind-to-frame-and-call-vop
 235 (defvar *interr-current-bsp* nil)
 236
 237 (defun internal-error (context continuable)
 238   (declare (type system-area-pointer context))
 239   (declare (ignore continuable))
 240   (/show0 "entering INTERNAL-ERROR, CONTEXT=..")
 241   (/hexstr context)
 242   (let (#!+unwind-to-frame-and-call-vop
 243         (*interr-current-bsp*
 244           ;; Needs to be done before anything is bound
 245           (%primitive sb!c:current-binding-pointer)))
 246    (infinite-error-protect
 247     (/show0 "about to bind ALIEN-CONTEXT")
 248     (let* ((alien-context (sap-alien context (* os-context-t)))
 249            #!+c-stack-is-control-stack
 250            (fp-and-pc (make-array 2 :element-type 'word)))
 251       #!+c-stack-is-control-stack
 252       (declare (truly-dynamic-extent fp-and-pc))
 253       #!+c-stack-is-control-stack
 254       (setf (aref fp-and-pc 0) (sb!vm:context-register alien-context sb!vm::cfp-offset)
 255             (aref fp-and-pc 1) (sb!sys:sap-int (sb!vm:context-pc alien-context)))
 256       (let (#!+c-stack-is-control-stack
 257             (*saved-fp-and-pcs* (cons fp-and-pc *saved-fp-and-pcs*)))
 258         #!+c-stack-is-control-stack
 259         (declare (truly-dynamic-extent *saved-fp-and-pcs*))
 260        (/show0 "about to bind ERROR-NUMBER and ARGUMENTS"))
 261       (multiple-value-bind (error-number arguments)
 262           (sb!vm:internal-error-args alien-context)
 263         (with-interrupt-bindings
 264           (multiple-value-bind (name sb!debug:*stack-top-hint*)
 265               (find-interrupted-name-and-frame)
 266             (/show0 "back from FIND-INTERRUPTED-NAME")
 267             (let ((*current-internal-error* error-number)
 268                   (fp (int-sap (sb!vm:context-register alien-context
 269                                                        sb!vm::cfp-offset)))
 270                   (handler (and (< -1 error-number (length *internal-errors*))
 271                                 (svref *internal-errors* error-number))))
 272               (cond ((and (functionp handler)
 273                           (internal-error-args-ok arguments handler))
 274                      (macrolet ((arg (n)
 275                                   `(sb!di::sub-access-debug-var-slot
 276                                     fp (nth ,n arguments) alien-context)))
 277                        (ecase (length arguments)
 278                          (0 (funcall handler name))
 279                          (1 (funcall handler name (arg 0)))
 280                          (2 (funcall handler name (arg 0) (arg 1)))
 281                          (3 (funcall handler name (arg 0) (arg 1) (arg 2))))))
 282                     ((typep handler '(or symbol cons))
 283                      (error 'type-error
 284                             :datum (sb!di::sub-access-debug-var-slot
 285                                     fp (first arguments) alien-context)
 286                             :expected-type handler))
 287                     ((eql handler 0) ; if (DEFERR x) was inadvertently omitted
 288                      (error 'simple-error
 289                             :format-control
 290                             "unknown internal error, ~D, args=~S"
 291                             :format-arguments
 292                             (list error-number
 293                                   (mapcar (lambda (sc-offset)
 294                                             (sb!di::sub-access-debug-var-slot
 295                                              fp sc-offset alien-context))
 296                                           arguments))))
 297                     (t                  ; wtf?
 298                      (error 'simple-error
 299                             :format-control "internal error ~D: ~A; args=~S"
 300                             :format-arguments
 301                             (list error-number
 302                                   handler
 303                                   (mapcar (lambda (sc-offset)
 304                                             (sb!di::sub-access-debug-var-slot
 305                                              fp sc-offset alien-context))
 306                                           arguments)))))))))))))
 307
 308 (defun control-stack-exhausted-error ()
 309   (let ((sb!debug:*stack-top-hint* nil))
 310     (infinite-error-protect
 311      (format *error-output*
 312              "Control stack guard page temporarily disabled: proceed with caution~%")
 313      (error 'control-stack-exhausted))))
 314
 315 (defun binding-stack-exhausted-error ()
 316   (let ((sb!debug:*stack-top-hint* nil))
 317     (infinite-error-protect
 318      (format *error-output*
 319              "Binding stack guard page temporarily disabled: proceed with caution~%")
 320      (error 'binding-stack-exhausted))))
 321
 322 (defun alien-stack-exhausted-error ()
 323   (let ((sb!debug:*stack-top-hint* nil))
 324     (infinite-error-protect
 325      (format *error-output*
 326              "Alien stack guard page temporarily disabled: proceed with caution~%")
 327      (error 'alien-stack-exhausted))))
 328
 329 ;;; KLUDGE: we keep a single HEAP-EXHAUSTED-ERROR object around, so
 330 ;;; that we don't need to allocate it when running out of
 331 ;;; memory. Similarly we pass the amounts in special variables as
 332 ;;; there may be multiple threads running into trouble at the same
 333 ;;; time. The condition is created by GC-REINIT.
 334 (defvar *heap-exhausted-error-condition*)
 335 (defvar *heap-exhausted-error-available-bytes*)
 336 (defvar *heap-exhausted-error-requested-bytes*)
 337
 338 (defun heap-exhausted-error (available requested)
 339   ;; Double word aligned bytes, can be passed as fixnums to avoid
 340   ;; allocating bignums on the C side.
 341   (declare (fixnum available requested))
 342   (infinite-error-protect
 343    (let ((*heap-exhausted-error-available-bytes*
 344            (ash available sb!vm:n-fixnum-tag-bits))
 345          (*heap-exhausted-error-requested-bytes*
 346            (ash requested sb!vm:n-fixnum-tag-bits)))
 347      (error *heap-exhausted-error-condition*))))
 348
 349 (defun undefined-alien-variable-error ()
 350   (error 'undefined-alien-variable-error))
 351
 352 #!-win32
 353 (define-alien-variable current-memory-fault-address unsigned)
 354
 355 #!-win32
 356 (defun memory-fault-error ()
 357   (error 'memory-fault-error
 358          :address current-memory-fault-address))
 359
 360 ;;; This is SIGTRAP / EXCEPTION_BREAKPOINT that runtime could not deal
 361 ;;; with. Prior to Windows we just had a Lisp side handler for
 362 ;;; SIGTRAP, but now we need to deal with this portably.
 363 (defun unhandled-trap-error (context-sap)
 364   (declare (type system-area-pointer context-sap))
 365   (infinite-error-protect
 366    (let ((context (sap-alien context-sap (* os-context-t))))
 367      (error 'breakpoint-error
 368             :context context
 369             :address (sap-int (sb!vm:context-pc context))))))