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