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                       (still-bad "Bad value when restarting ~s: ~s"
  63                                  name value)))
  64                    (still-bad (if (fdefn-p value)
  65                                   "~S is still undefined"
  66                                   "Can't replace ~s with ~s because it is undefined")
  67                               name value)))
  68              (set-value (function retrying)
  69                (if retrying
  70                    (retry-value function)
  71                    (sb!di::sub-set-debug-var-slot
  72                     nil tn-offset
  73                     (retry-value function)
  74                     *current-internal-error-context*)))
  75              (still-bad (format-control &rest format-arguments)
  76                (try (make-condition 'retry-undefined-function
  77                                     :name name
  78                                     :format-control format-control
  79                                     :format-arguments format-arguments)
  80                     t))
  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   (restart-case
 162       (error 'simple-program-error
 163              :format-control "invalid number of arguments: ~S"
 164              :format-arguments (list nargs))
 165     #!+(or x86-64 arm64)
 166     (replace-function (value)
 167       :report (lambda (stream)
 168                 (format stream "Call a different function with the same arguments"))
 169       :interactive read-evaluated-form
 170       (sb!vm::context-call-function *current-internal-error-context*
 171                                     (fdefinition value)))
 172     #!+(or x86-64 arm64)
 173     (call-form (form)
 174       :report (lambda (stream)
 175                 (format stream "Call a different form"))
 176       :interactive read-evaluated-form
 177       (sb!vm::context-call-function *current-internal-error-context*
 178                                     (lambda ()
 179                                       ;; Don't invoke the compiler in
 180                                       ;; case it's dealing with an
 181                                       ;; error within the compiler
 182                                       (let (#!+(or sb-eval sb-fasteval)
 183                                             (*evaluator-mode* :interpret))
 184                                         (eval form)))
 185                                     0))))
 186
 187 (deferr local-invalid-arg-count-error (nargs name)
 188   (error 'simple-program-error
 189          :format-control "~S called with invalid number of arguments: ~S"
 190          :format-arguments (list name nargs)))
 191
 192 (deferr bogus-arg-to-values-list-error (list)
 193   (with-simple-restart (continue "Ignore the last CDR")
 194     (error 'values-list-argument-error :datum list :expected-type 'list)))
 195
 196 (defun restart-unbound (symbol context)
 197   (multiple-value-bind (tn-offset pc-offset)
 198       (sb!c::decode-restart-location context)
 199     (labels ((retry-value (value)
 200                (multiple-value-bind (type defined)
 201                    (info :variable :type symbol)
 202                  (if (and defined
 203                           (not (ctypep value type)))
 204                      (still-bad "Type mismatch when restarting unbound symbol error:~@
 205                                  ~s is not of type ~/sb!impl:print-type/"
 206                                 value type)
 207                      value)))
 208              (set-value (value &optional set-symbol)
 209                (sb!di::sub-set-debug-var-slot
 210                 nil tn-offset (retry-value value)
 211                 *current-internal-error-context*)
 212                (sb!vm::incf-context-pc *current-internal-error-context*
 213                                        pc-offset)
 214                (when set-symbol
 215                  (set symbol value))
 216                (return-from restart-unbound))
 217              (retry-evaluation ()
 218                (if (boundp symbol)
 219                    (set-value (symbol-value symbol))
 220                    (still-bad "~s is still unbound" symbol)))
 221              (still-bad (format-control &rest format-arguments)
 222                (try (make-condition 'retry-unbound-variable
 223                                     :name symbol
 224                                     :format-control format-control
 225                                     :format-arguments format-arguments)))
 226              (try (condition)
 227                (restart-case (error condition)
 228                  (continue ()
 229                    :report (lambda (stream)
 230                              (format stream "Retry using ~s." symbol))
 231                    (retry-evaluation))
 232                  (use-value (value)
 233                    :report (lambda (stream)
 234                              (format stream "Use specified value."))
 235                    :interactive read-evaluated-form
 236                    (set-value value))
 237                  (store-value (value)
 238                    :report (lambda (stream)
 239                              (format stream "Set specified value and use it."))
 240                    :interactive read-evaluated-form
 241                    (set-value value t)))))
 242       (try (make-condition 'unbound-variable :name symbol)))))
 243
 244 (deferr unbound-symbol-error (symbol)
 245   (let* ((context (sb!di:error-context)))
 246     (if context
 247         (restart-unbound symbol context)
 248         (error 'unbound-variable :name symbol))))
 249
 250 (deferr invalid-unwind-error ()
 251   (error 'simple-control-error
 252          :format-control
 253          "attempt to RETURN-FROM a block or GO to a tag that no longer exists"))
 254
 255 (deferr unseen-throw-tag-error (tag)
 256   (let ((text "attempt to THROW to a tag that does not exist: ~S"))
 257     #!+sb-fasteval
 258     (when (listp tag)
 259       (binding* ((frame (find-interrupted-frame))
 260                  (name (sb!di:debug-fun-name (sb!di:frame-debug-fun frame)))
 261                  (down (and (eq name 'sb!c::unwind) ; is this tautological ?
 262                             (sb!di:frame-down frame)) :exit-if-null))
 263         (case (sb!di:debug-fun-name (sb!di:frame-debug-fun down))
 264          ((return-from)
 265           (setq text "attempt to RETURN-FROM an exited block: ~S"
 266                      ;; block name was wrapped in a cons
 267                 tag (car tag)))
 268          ((go)
 269                      ;; FIXME: can we reverse-engineer the tag name from
 270                      ;; the object that was thrown, for a better diagnostic?
 271           (setq text "attempt to GO into an exited tagbody")))))
 272     (error 'simple-control-error
 273            :format-control text :format-arguments (list tag))))
 274
 275 (deferr nil-fun-returned-error (function)
 276   (error 'simple-control-error
 277          :format-control
 278          "A function with declared result type NIL returned:~%  ~S"
 279          :format-arguments (list function)))
 280
 281 (deferr nil-array-accessed-error (array)
 282   (error 'nil-array-accessed-error
 283          :datum array :expected-type '(not (array nil))))
 284
 285 (deferr division-by-zero-error (this that)
 286   (error 'division-by-zero
 287          :operation '/
 288          :operands (list this that)))
 289
 290 (deferr object-not-type-error (object type)
 291   (if (invalid-array-p object)
 292       (invalid-array-error object)
 293       (error (if (and (%instancep object)
 294                       (layout-invalid (%instance-layout object)))
 295                  'layout-invalid
 296                  'type-error)
 297              :datum object
 298              :expected-type type
 299              :context (sb!di:error-context))))
 300
 301 (deferr layout-invalid-error (object layout)
 302   (error 'layout-invalid
 303          :datum object
 304          :expected-type (layout-classoid layout)))
 305
 306 (deferr odd-key-args-error ()
 307   (error 'simple-program-error
 308          :format-control "odd number of &KEY arguments"))
 309
 310 (deferr unknown-key-arg-error (key-name)
 311   (let ((context (sb!di:error-context)))
 312     (if (integerp context)
 313         (restart-case
 314             (error 'unknown-keyword-argument :name key-name)
 315           (continue ()
 316             :report (lambda (stream)
 317                       (format stream "Ignore all unknown keywords"))
 318             (sb!vm::incf-context-pc *current-internal-error-context*
 319                                     context)))
 320         (error 'unknown-keyword-argument :name key-name))))
 321
 322 ;; TODO: make the arguments (ARRAY INDEX &optional BOUND)
 323 ;; and don't need the bound for vectors. Just read it.
 324 (deferr invalid-array-index-error (array bound index)
 325   (invalid-array-index-error array index bound))
 326
 327 (deferr tls-exhausted-error ()
 328   ;; There is nothing we can do about it. A number of entries in the
 329   ;; tls could be reserved and made available for recovery but since
 330   ;; tls indices are never reused it would be kind of silly and
 331   ;; without it signalling an error is more than likely to end in a
 332   ;; recursive error.
 333   (%primitive print "Thread local storage exhausted.")
 334   (sb!impl::%halt))
 335 \f
 336 ;;;; INTERNAL-ERROR signal handler
 337
 338 ;;; This is needed for restarting XEPs, which do not bind anything but
 339 ;;; also do not save their own BSP, and we need to discard the
 340 ;;; bindings made by the error handling machinery.
 341 #!+unwind-to-frame-and-call-vop
 342 (defvar *interr-current-bsp* nil)
 343
 344 (defun internal-error (context continuable)
 345   (declare (type system-area-pointer context))
 346   (declare (ignore continuable))
 347   (/show0 "entering INTERNAL-ERROR, CONTEXT=..")
 348   (/hexstr context)
 349   (let (#!+unwind-to-frame-and-call-vop
 350         (*interr-current-bsp*
 351           ;; Needs to be done before anything is bound
 352           (%primitive sb!c:current-binding-pointer)))
 353    (infinite-error-protect
 354     (/show0 "about to bind ALIEN-CONTEXT")
 355     (let* ((alien-context (sap-alien context (* os-context-t)))
 356            #!+c-stack-is-control-stack
 357            (fp-and-pc (make-array 2 :element-type 'word)))
 358       #!+c-stack-is-control-stack
 359       (declare (truly-dynamic-extent fp-and-pc))
 360       #!+c-stack-is-control-stack
 361       (setf (aref fp-and-pc 0) (sb!vm:context-register alien-context sb!vm::cfp-offset)
 362             (aref fp-and-pc 1) (sb!sys:sap-int (sb!vm:context-pc alien-context)))
 363       (let (#!+c-stack-is-control-stack
 364             (*saved-fp-and-pcs* (cons fp-and-pc *saved-fp-and-pcs*)))
 365         #!+c-stack-is-control-stack
 366         (declare (truly-dynamic-extent *saved-fp-and-pcs*))
 367        (/show0 "about to bind ERROR-NUMBER and ARGUMENTS"))
 368       (multiple-value-bind (error-number arguments
 369                             *current-internal-trap-number*)
 370           (sb!vm:internal-error-args alien-context)
 371         (with-interrupt-bindings
 372           (let ((sb!debug:*stack-top-hint* (find-interrupted-frame))
 373                 (*current-internal-error* error-number)
 374                 (*current-internal-error-args* arguments)
 375                 (*current-internal-error-context* alien-context)
 376                 (fp (int-sap (sb!vm:context-register alien-context
 377                                                      sb!vm::cfp-offset))))
 378             (if (and (>= error-number (length **internal-error-handlers**))
 379                      (< error-number (length sb!c:+backend-internal-errors+)))
 380                 (let ((context (sb!di:error-context)))
 381                   (if (typep context '(cons (eql :struct-read)))
 382                       ;; This was shoehorned into being a "type error"
 383                       ;; which isn't the best way to explain it to the user.
 384                       ;; However, from an API stance, it makes some sense to signal
 385                       ;; a TYPE-ERROR since there may be existing code that catches
 386                       ;; unbound slots errors as type-errors. Our tests certainly do,
 387                       ;; but perhaps only as an artifact of the implementation.
 388                       (destructuring-bind (struct-name . slot-name) (cdr context)
 389                         ;; Infer the slot type, but fail safely. The message is enough,
 390                         ;; and the required type is pretty much irrelevant.
 391                         (let* ((dd (find-defstruct-description struct-name))
 392                                (dsd (and dd (find slot-name (dd-slots dd) :key #'dsd-name))))
 393                           (error 'simple-type-error
 394                                  :format-control "Accessed uninitialized slot ~S of structure ~S"
 395                                  :format-arguments (list slot-name struct-name)
 396                                  :datum (make-unbound-marker)
 397                                  :expected-type (if dsd (dsd-type dsd) 't))))
 398                       (error 'type-error
 399                              :datum (sb!di::sub-access-debug-var-slot
 400                                      fp (first arguments) alien-context)
 401                              :expected-type
 402                              (car (svref sb!c:+backend-internal-errors+
 403                                          error-number))
 404                              :context context)))
 405                 (let ((handler
 406                         (and (typep error-number
 407                                     '#.`(mod ,(length **internal-error-handlers**)))
 408                              (svref **internal-error-handlers** error-number))))
 409                   (cond
 410                     ((functionp handler)
 411                      ;; INTERNAL-ERROR-ARGS supplies the right amount of arguments
 412                      (macrolet ((arg (n)
 413                                   `(sb!di::sub-access-debug-var-slot
 414                                     fp (nth ,n arguments) alien-context)))
 415                        (ecase (length arguments)
 416                          (0 (funcall handler))
 417                          (1 (funcall handler (arg 0)))
 418                          (2 (funcall handler (arg 0) (arg 1)))
 419                          (3 (funcall handler (arg 0) (arg 1) (arg 2))))))
 420                     ((eql handler 0) ; if (DEFERR x) was inadvertently omitted
 421                      (error 'simple-error
 422                             :format-control
 423                             "unknown internal error, ~D, args=~S"
 424                             :format-arguments
 425                             (list error-number
 426                                   (mapcar (lambda (sc-offset)
 427                                             (sb!di::sub-access-debug-var-slot
 428                                              fp sc-offset alien-context))
 429                                           arguments))))
 430                     (t                  ; wtf?
 431                      (error 'simple-error
 432                             :format-control "internal error ~D: ~A; args=~S"
 433                             :format-arguments
 434                             (list error-number
 435                                   handler
 436                                   (mapcar (lambda (sc-offset)
 437                                             (sb!di::sub-access-debug-var-slot
 438                                              fp sc-offset alien-context))
 439                                           arguments))))))))))))))
 440
 441 (defun control-stack-exhausted-error ()
 442   (let ((sb!debug:*stack-top-hint* nil))
 443     (infinite-error-protect
 444      (format *error-output*
 445              "Control stack guard page temporarily disabled: proceed with caution~%")
 446      (error 'control-stack-exhausted))))
 447
 448 (defun binding-stack-exhausted-error ()
 449   (let ((sb!debug:*stack-top-hint* nil))
 450     (infinite-error-protect
 451      (format *error-output*
 452              "Binding stack guard page temporarily disabled: proceed with caution~%")
 453      (error 'binding-stack-exhausted))))
 454
 455 (defun alien-stack-exhausted-error ()
 456   (let ((sb!debug:*stack-top-hint* nil))
 457     (infinite-error-protect
 458      (format *error-output*
 459              "Alien stack guard page temporarily disabled: proceed with caution~%")
 460      (error 'alien-stack-exhausted))))
 461
 462 ;;; KLUDGE: we keep a single HEAP-EXHAUSTED-ERROR object around, so
 463 ;;; that we don't need to allocate it when running out of
 464 ;;; memory. Similarly we pass the amounts in special variables as
 465 ;;; there may be multiple threads running into trouble at the same
 466 ;;; time. The condition is created by GC-REINIT.
 467 (define-load-time-global *heap-exhausted-error-condition*
 468   (make-condition 'heap-exhausted-error))
 469 (defvar *heap-exhausted-error-available-bytes*)
 470 (defvar *heap-exhausted-error-requested-bytes*)
 471
 472 (defun heap-exhausted-error (available requested)
 473   ;; Double word aligned bytes, can be passed as fixnums to avoid
 474   ;; allocating bignums on the C side.
 475   (declare (fixnum available requested))
 476   (infinite-error-protect
 477    (let ((*heap-exhausted-error-available-bytes*
 478            (ash available sb!vm:n-fixnum-tag-bits))
 479          (*heap-exhausted-error-requested-bytes*
 480            (ash requested sb!vm:n-fixnum-tag-bits)))
 481      (error *heap-exhausted-error-condition*))))
 482
 483 (defun undefined-alien-variable-error ()
 484   (declare (optimize allow-non-returning-tail-call))
 485   (error 'undefined-alien-variable-error))
 486
 487 #!-win32
 488 (define-alien-variable current-memory-fault-address unsigned)
 489
 490 #!-win32
 491 (defun memory-fault-error ()
 492   (let ((sb!debug:*stack-top-hint* (find-interrupted-frame)))
 493     (error 'memory-fault-error
 494            :address current-memory-fault-address)))
 495
 496 ;;; This is SIGTRAP / EXCEPTION_BREAKPOINT that runtime could not deal
 497 ;;; with. Prior to Windows we just had a Lisp side handler for
 498 ;;; SIGTRAP, but now we need to deal with this portably.
 499 (defun unhandled-trap-error (context-sap)
 500   (declare (type system-area-pointer context-sap))
 501   (infinite-error-protect
 502    (let ((context (sap-alien context-sap (* os-context-t))))
 503      (error 'breakpoint-error
 504             :context context
 505             :address (sap-int (sb!vm:context-pc context))))))