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 ;;; Backtrace code may want to know the error that caused
  40 ;;; interruption, but there are other means to get code interrupted
  41 ;;; and inspecting code around PC for the error number may yield wrong
  42 ;;; results.
  43 (defvar *current-internal-error* nil)
  44 (defvar *current-internal-trap-number*)
  45 (defvar *current-internal-error-args*)
  46
  47 #!+undefined-fun-restarts
  48 (defun restart-undefined (name fdefn-or-symbol context)
  49   (multiple-value-bind (tn-offset pc-offset)
  50       (if context
  51           (sb!c::decode-restart-location context)
  52           (car *current-internal-error-args*))
  53     (labels ((retry-value (value)
  54                (or (typecase value
  55                      (fdefn (fdefn-fun value))
  56                      (symbol
  57                       (let ((fdefn (symbol-fdefn value)))
  58                         (and fdefn
  59                              (fdefn-fun fdefn))))
  60                      (function value)
  61                      (t
  62                       (try (make-condition 'retry-undefined-function
  63                                            :name name
  64                                            :format-control "Bad value when restarting ~s: ~s"
  65                                            :format-arguments (list name value))
  66                            t)))
  67                    (try (make-condition 'retry-undefined-function
  68                                         :name name
  69                                         :format-control (if (fdefn-p value)
  70                                                             "~S is still undefined"
  71                                                             "Can't replace ~s with ~s because it is undefined")
  72                                         :format-arguments (list name value))
  73                         t)))
  74              (set-value (function retrying)
  75                (if retrying
  76                    (retry-value function)
  77                    (sb!di::sub-set-debug-var-slot
  78                     nil tn-offset
  79                     (retry-value function)
  80                     *current-internal-error-context*)))
  81              (try (condition &optional retrying)
  82                (cond (context
  83                       ;; The #'abc case from SAFE-FDEFN-FUN, CONTEXT
  84                       ;; specifies the offset from the error location
  85                       ;; where it can retry checking the FDEFN
  86                       (prog1
  87                           (restart-case (error condition)
  88                             (continue ()
  89                               :report (lambda (stream)
  90                                         (format stream "Retry using ~s." name))
  91                               (set-value fdefn-or-symbol retrying))
  92                             (use-value (value)
  93                               :report (lambda (stream)
  94                                         (format stream "Use specified function."))
  95                               :interactive read-evaluated-form
  96                               (set-value value retrying)))
  97                         (unless retrying
  98                           (sb!vm::incf-context-pc *current-internal-error-context*
  99                                                   pc-offset))))
 100                      (t
 101                       (restart-case (error condition)
 102                         (continue ()
 103                           :report (lambda (stream)
 104                                     (format stream "Retry calling ~s." name))
 105                           (set-value fdefn-or-symbol retrying))
 106                         (use-value (value)
 107                           :report (lambda (stream)
 108                                     (format stream "Call specified function."))
 109                           :interactive read-evaluated-form
 110                           (set-value value retrying))
 111                         (return-value (&rest values)
 112                           :report (lambda (stream)
 113                                     (format stream "Return specified values."))
 114                           :interactive mv-read-evaluated-form
 115                           (set-value (lambda (&rest args)
 116                                        (declare (ignore args))
 117                                        (values-list values))
 118                                      retrying))
 119                         (return-nothing ()
 120                           :report (lambda (stream)
 121                                     (format stream "Return zero values."))
 122                           (set-value (lambda (&rest args)
 123                                        (declare (ignore args))
 124                                        (values))
 125                                      retrying)))))))
 126       (try (make-condition 'undefined-function :name name)))))
 127
 128 (deferr undefined-fun-error (fdefn-or-symbol)
 129   (let ((name (etypecase fdefn-or-symbol
 130                 (symbol fdefn-or-symbol)
 131                 (fdefn (let ((name (fdefn-name fdefn-or-symbol)))
 132                          ;; fasteval stores weird things in the NAME slot
 133                          ;; of fdefns of special forms. Have to grab the
 134                          ;; special form name out of that.
 135                          (cond #!+(and sb-fasteval immobile-code)
 136                                ((and (listp name) (functionp (car name)))
 137                                 (cadr (%fun-name (car name))))
 138                                (t
 139                                 name))))))
 140         #!+undefined-fun-restarts
 141         context)
 142     (cond #!+undefined-fun-restarts
 143           ((or (= *current-internal-trap-number* sb!vm:cerror-trap)
 144                (integerp (setf context (sb!di:error-context))))
 145            (restart-undefined name fdefn-or-symbol context))
 146           (t
 147            (error 'undefined-function :name name)))))
 148
 149 #!+(or arm arm64 x86-64)
 150 (deferr undefined-alien-fun-error (address)
 151   (error 'undefined-alien-function-error
 152          :name
 153          (and (integerp address)
 154               (sap-foreign-symbol (int-sap address)))))
 155
 156 #!-(or arm arm64 x86-64)
 157 (defun undefined-alien-fun-error ()
 158   (error 'undefined-alien-function-error))
 159
 160 (deferr invalid-arg-count-error (nargs)
 161   (error 'simple-program-error
 162          :format-control "invalid number of arguments: ~S"
 163          :format-arguments (list nargs)))
 164
 165 (deferr local-invalid-arg-count-error (nargs name)
 166   (error 'simple-program-error
 167          :format-control "~S called with invalid number of arguments: ~S"
 168          :format-arguments (list name nargs)))
 169
 170 (deferr bogus-arg-to-values-list-error (list)
 171   (error 'simple-type-error
 172          :datum list
 173          :expected-type 'list
 174          :format-control
 175          "~@<attempt to use VALUES-LIST on a dotted list: ~2I~_~S~:>"
 176          :format-arguments (list list)))
 177
 178 (deferr unbound-symbol-error (symbol)
 179   (error 'unbound-variable :name symbol))
 180
 181 (deferr invalid-unwind-error ()
 182   (error 'simple-control-error
 183          :format-control
 184          "attempt to RETURN-FROM a block or GO to a tag that no longer exists"))
 185
 186 (deferr unseen-throw-tag-error (tag)
 187   (let ((text "attempt to THROW to a tag that does not exist: ~S"))
 188     #!+sb-fasteval
 189     (when (listp tag)
 190       (binding* ((frame (find-interrupted-frame))
 191                  (name (sb!di:debug-fun-name (sb!di:frame-debug-fun frame)))
 192                  (down (and (eq name 'sb!c::unwind) ; is this tautological ?
 193                             (sb!di:frame-down frame)) :exit-if-null))
 194         (case (sb!di:debug-fun-name (sb!di:frame-debug-fun down))
 195          ((return-from)
 196           (setq text "attempt to RETURN-FROM an exited block: ~S"
 197                      ;; block name was wrapped in a cons
 198                 tag (car tag)))
 199          ((go)
 200                      ;; FIXME: can we reverse-engineer the tag name from
 201                      ;; the object that was thrown, for a better diagnostic?
 202           (setq text "attempt to GO into an exited tagbody")))))
 203     (error 'simple-control-error
 204            :format-control text :format-arguments (list tag))))
 205
 206 (deferr nil-fun-returned-error (function)
 207   (error 'simple-control-error
 208          :format-control
 209          "A function with declared result type NIL returned:~%  ~S"
 210          :format-arguments (list function)))
 211
 212 (deferr nil-array-accessed-error (array)
 213   (error 'nil-array-accessed-error
 214          :datum array :expected-type '(not (array nil))))
 215
 216 (deferr division-by-zero-error (this that)
 217   (error 'division-by-zero
 218          :operation '/
 219          :operands (list this that)))
 220
 221 (deferr object-not-type-error (object type)
 222   (if (invalid-array-p object)
 223       (invalid-array-error object)
 224       (error (if (and (%instancep object)
 225                       (layout-invalid (%instance-layout object)))
 226                  'layout-invalid
 227                  'type-error)
 228              :datum object
 229              :expected-type type
 230              :context (sb!di:error-context))))
 231
 232 (deferr layout-invalid-error (object layout)
 233   (error 'layout-invalid
 234          :datum object
 235          :expected-type (layout-classoid layout)))
 236
 237 (deferr odd-key-args-error ()
 238   (error 'simple-program-error
 239          :format-control "odd number of &KEY arguments"))
 240
 241 (deferr unknown-key-arg-error (key-name)
 242   (let ((context (sb!di:error-context)))
 243     (if (integerp context)
 244         (restart-case
 245             (error 'unknown-keyword-argument :name key-name)
 246           (continue ()
 247             :report (lambda (stream)
 248                       (format stream "Ignore all unknown keywords"))
 249             (sb!vm::incf-context-pc *current-internal-error-context*
 250                                     context)))
 251         (error 'unknown-keyword-argument :name key-name))))
 252
 253 ;; TODO: make the arguments (ARRAY INDEX &optional BOUND)
 254 ;; and don't need the bound for vectors. Just read it.
 255 (deferr invalid-array-index-error (array bound index)
 256   (invalid-array-index-error array index bound))
 257
 258 (deferr tls-exhausted-error ()
 259   ;; There is nothing we can do about it. A number of entries in the
 260   ;; tls could be reserved and made available for recovery but since
 261   ;; tls indices are never reused it would be kind of silly and
 262   ;; without it signalling an error is more than likely to end in a
 263   ;; recursive error.
 264   (%primitive print "Thread local storage exhausted.")
 265   (sb!impl::%halt))
 266 \f
 267 ;;;; INTERNAL-ERROR signal handler
 268
 269 ;;; This is needed for restarting XEPs, which do not bind anything but
 270 ;;; also do not save their own BSP, and we need to discard the
 271 ;;; bindings made by the error handling machinery.
 272 #!+unwind-to-frame-and-call-vop
 273 (defvar *interr-current-bsp* nil)
 274
 275 (defun internal-error (context continuable)
 276   (declare (type system-area-pointer context))
 277   (declare (ignore continuable))
 278   (/show0 "entering INTERNAL-ERROR, CONTEXT=..")
 279   (/hexstr context)
 280   (let (#!+unwind-to-frame-and-call-vop
 281         (*interr-current-bsp*
 282           ;; Needs to be done before anything is bound
 283           (%primitive sb!c:current-binding-pointer)))
 284    (infinite-error-protect
 285     (/show0 "about to bind ALIEN-CONTEXT")
 286     (let* ((alien-context (sap-alien context (* os-context-t)))
 287            #!+c-stack-is-control-stack
 288            (fp-and-pc (make-array 2 :element-type 'word)))
 289       #!+c-stack-is-control-stack
 290       (declare (truly-dynamic-extent fp-and-pc))
 291       #!+c-stack-is-control-stack
 292       (setf (aref fp-and-pc 0) (sb!vm:context-register alien-context sb!vm::cfp-offset)
 293             (aref fp-and-pc 1) (sb!sys:sap-int (sb!vm:context-pc alien-context)))
 294       (let (#!+c-stack-is-control-stack
 295             (*saved-fp-and-pcs* (cons fp-and-pc *saved-fp-and-pcs*)))
 296         #!+c-stack-is-control-stack
 297         (declare (truly-dynamic-extent *saved-fp-and-pcs*))
 298        (/show0 "about to bind ERROR-NUMBER and ARGUMENTS"))
 299       (multiple-value-bind (error-number arguments
 300                             *current-internal-trap-number*)
 301           (sb!vm:internal-error-args alien-context)
 302         (with-interrupt-bindings
 303           (let ((sb!debug:*stack-top-hint* (find-interrupted-frame))
 304                 (*current-internal-error* error-number)
 305                 (*current-internal-error-args* arguments)
 306                 (*current-internal-error-context* alien-context)
 307                 (fp (int-sap (sb!vm:context-register alien-context
 308                                                      sb!vm::cfp-offset))))
 309             (if (and (>= error-number (length **internal-error-handlers**))
 310                      (< error-number (length sb!c:+backend-internal-errors+)))
 311                 (let ((context (sb!di:error-context)))
 312                   (if (typep context '(cons (eql :struct-read)))
 313                       ;; This was shoehorned into being a "type error"
 314                       ;; which isn't the best way to explain it to the user.
 315                       ;; However, from an API stance, it makes some sense to signal
 316                       ;; a TYPE-ERROR since there may be existing code that catches
 317                       ;; unbound slots errors as type-errors. Our tests certainly do,
 318                       ;; but perhaps only as an artifact of the implementation.
 319                       (destructuring-bind (struct-name . slot-name) (cdr context)
 320                         ;; Infer the slot type, but fail safely. The message is enough,
 321                         ;; and the required type is pretty much irrelevant.
 322                         (let* ((dd (find-defstruct-description struct-name))
 323                                (dsd (and dd (find slot-name (dd-slots dd) :key #'dsd-name))))
 324                           (error 'simple-type-error
 325                                  :format-control "Accessed uninitialized slot ~S of structure ~S"
 326                                  :format-arguments (list slot-name struct-name)
 327                                  :datum (make-unbound-marker)
 328                                  :expected-type (if dsd (dsd-type dsd) 't))))
 329                       (error 'type-error
 330                              :datum (sb!di::sub-access-debug-var-slot
 331                                      fp (first arguments) alien-context)
 332                              :expected-type
 333                              (car (svref sb!c:+backend-internal-errors+
 334                                          error-number))
 335                              :context context)))
 336                 (let ((handler
 337                         (and (typep error-number
 338                                     '#.`(mod ,(length **internal-error-handlers**)))
 339                              (svref **internal-error-handlers** error-number))))
 340                   (cond
 341                     ((functionp handler)
 342                      ;; INTERNAL-ERROR-ARGS supplies the right amount of arguments
 343                      (macrolet ((arg (n)
 344                                   `(sb!di::sub-access-debug-var-slot
 345                                     fp (nth ,n arguments) alien-context)))
 346                        (ecase (length arguments)
 347                          (0 (funcall handler))
 348                          (1 (funcall handler (arg 0)))
 349                          (2 (funcall handler (arg 0) (arg 1)))
 350                          (3 (funcall handler (arg 0) (arg 1) (arg 2))))))
 351                     ((eql handler 0) ; if (DEFERR x) was inadvertently omitted
 352                      (error 'simple-error
 353                             :format-control
 354                             "unknown internal error, ~D, args=~S"
 355                             :format-arguments
 356                             (list error-number
 357                                   (mapcar (lambda (sc-offset)
 358                                             (sb!di::sub-access-debug-var-slot
 359                                              fp sc-offset alien-context))
 360                                           arguments))))
 361                     (t                  ; wtf?
 362                      (error 'simple-error
 363                             :format-control "internal error ~D: ~A; args=~S"
 364                             :format-arguments
 365                             (list error-number
 366                                   handler
 367                                   (mapcar (lambda (sc-offset)
 368                                             (sb!di::sub-access-debug-var-slot
 369                                              fp sc-offset alien-context))
 370                                           arguments))))))))))))))
 371
 372 (defun control-stack-exhausted-error ()
 373   (let ((sb!debug:*stack-top-hint* nil))
 374     (infinite-error-protect
 375      (format *error-output*
 376              "Control stack guard page temporarily disabled: proceed with caution~%")
 377      (error 'control-stack-exhausted))))
 378
 379 (defun binding-stack-exhausted-error ()
 380   (let ((sb!debug:*stack-top-hint* nil))
 381     (infinite-error-protect
 382      (format *error-output*
 383              "Binding stack guard page temporarily disabled: proceed with caution~%")
 384      (error 'binding-stack-exhausted))))
 385
 386 (defun alien-stack-exhausted-error ()
 387   (let ((sb!debug:*stack-top-hint* nil))
 388     (infinite-error-protect
 389      (format *error-output*
 390              "Alien stack guard page temporarily disabled: proceed with caution~%")
 391      (error 'alien-stack-exhausted))))
 392
 393 ;;; KLUDGE: we keep a single HEAP-EXHAUSTED-ERROR object around, so
 394 ;;; that we don't need to allocate it when running out of
 395 ;;; memory. Similarly we pass the amounts in special variables as
 396 ;;; there may be multiple threads running into trouble at the same
 397 ;;; time. The condition is created by GC-REINIT.
 398 (define-load-time-global *heap-exhausted-error-condition*
 399   (make-condition 'heap-exhausted-error))
 400 (defvar *heap-exhausted-error-available-bytes*)
 401 (defvar *heap-exhausted-error-requested-bytes*)
 402
 403 (defun heap-exhausted-error (available requested)
 404   ;; Double word aligned bytes, can be passed as fixnums to avoid
 405   ;; allocating bignums on the C side.
 406   (declare (fixnum available requested))
 407   (infinite-error-protect
 408    (let ((*heap-exhausted-error-available-bytes*
 409            (ash available sb!vm:n-fixnum-tag-bits))
 410          (*heap-exhausted-error-requested-bytes*
 411            (ash requested sb!vm:n-fixnum-tag-bits)))
 412      (error *heap-exhausted-error-condition*))))
 413
 414 (defun undefined-alien-variable-error ()
 415   (declare (optimize allow-non-returning-tail-call))
 416   (error 'undefined-alien-variable-error))
 417
 418 #!-win32
 419 (define-alien-variable current-memory-fault-address unsigned)
 420
 421 #!-win32
 422 (defun memory-fault-error ()
 423   (let ((sb!debug:*stack-top-hint* (find-interrupted-frame)))
 424     (error 'memory-fault-error
 425            :address current-memory-fault-address)))
 426
 427 ;;; This is SIGTRAP / EXCEPTION_BREAKPOINT that runtime could not deal
 428 ;;; with. Prior to Windows we just had a Lisp side handler for
 429 ;;; SIGTRAP, but now we need to deal with this portably.
 430 (defun unhandled-trap-error (context-sap)
 431   (declare (type system-area-pointer context-sap))
 432   (infinite-error-protect
 433    (let ((context (sap-alien context-sap (* os-context-t))))
 434      (error 'breakpoint-error
 435             :context context
 436             :address (sap-int (sb!vm:context-pc context))))))