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 arm64 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 arm64 x86-64)
  53 (defun undefined-alien-fun-error ()
  54   (error 'undefined-alien-function-error))
  55
  56 (deferr invalid-arg-count-error (nargs)
  57   (error 'simple-program-error
  58          :format-control "invalid number of arguments: ~S"
  59          :format-arguments (list nargs)))
  60
  61 (deferr local-invalid-arg-count-error (nargs name)
  62   (error 'simple-program-error
  63          :format-control "~S called with invalid number of arguments: ~S"
  64          :format-arguments (list name 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   (let ((text "attempt to THROW to a tag that does not exist: ~S"))
  84     #!+sb-fasteval
  85     (when (listp tag)
  86       (multiple-value-bind (name frame)
  87           (sb!debug::find-interrupted-name-and-frame)
  88         ;; KLUDGE: can't inline due to build ordering problem.
  89         (declare (notinline sb!di:frame-debug-fun))
  90         (let ((down (and (eq name 'sb!c::unwind) ; is this tautological ?
  91                          (sb!di:frame-down frame))))
  92           (when frame
  93             ;; Is this really the canonical way to get a frame name?
  94             (let ((prev-frame-name
  95                    (sb!di:debug-fun-name (sb!di:frame-debug-fun down))))
  96               (when (and (listp prev-frame-name)
  97                          (eq (car prev-frame-name) 'sb!c::xep))
  98                 (setq prev-frame-name (second prev-frame-name)))
  99               (cond ((equal prev-frame-name '(eval return-from))
 100                      (setq text "attempt to RETURN-FROM an exited block: ~S"
 101                            ;; block name was wrapped in a cons
 102                            tag (car tag)))
 103                     ((equal prev-frame-name '(eval go))
 104                      ;; FIXME: can we reverse-engineer the tag name from
 105                      ;; the object that was thrown, for a better diagnostic?
 106                      (setq text "attempt to GO into an exited tagbody"))))))))
 107     (error 'simple-control-error
 108            :format-control text :format-arguments (list tag))))
 109
 110 (deferr nil-fun-returned-error (function)
 111   (error 'simple-control-error
 112          :format-control
 113          "A function with declared result type NIL returned:~%  ~S"
 114          :format-arguments (list function)))
 115
 116 (deferr nil-array-accessed-error (array)
 117   (error 'nil-array-accessed-error
 118          :datum array :expected-type '(not (array nil))))
 119
 120 (deferr division-by-zero-error (this that)
 121   (error 'division-by-zero
 122          :operation '/
 123          :operands (list this that)))
 124
 125 (deferr object-not-type-error (object type)
 126   (if (invalid-array-p object)
 127       (invalid-array-error object)
 128       (error (if (and (%instancep object)
 129                       (layout-invalid (%instance-layout object)))
 130                  'layout-invalid
 131                  'type-error)
 132              :datum object
 133              :expected-type type)))
 134
 135 (deferr layout-invalid-error (object layout)
 136   (error 'layout-invalid
 137          :datum object
 138          :expected-type (layout-classoid layout)))
 139
 140 (deferr odd-key-args-error ()
 141   (error 'simple-program-error
 142          :format-control "odd number of &KEY arguments"))
 143
 144 (deferr unknown-key-arg-error (key-name)
 145   (error 'simple-program-error
 146          :format-control "unknown &KEY argument: ~S"
 147          :format-arguments (list key-name)))
 148
 149 ;; TODO: make the arguments (ARRAY INDEX &optional BOUND)
 150 ;; and don't need the bound for vectors. Just read it.
 151 (deferr invalid-array-index-error (array bound index)
 152   (invalid-array-index-error array index bound))
 153
 154 (deferr tls-exhausted-error ()
 155   ;; There is nothing we can do about it. A number of entries in the
 156   ;; tls could be reserved and made available for recovery but since
 157   ;; tls indices are never reused it would be kind of silly and
 158   ;; without it signalling an error is more than likely to end in a
 159   ;; recursive error.
 160   (%primitive print "Thread local storage exhausted.")
 161   (sb!impl::%halt))
 162 \f
 163
 164 ;;; Returns true if number of arguments matches required/optional
 165 ;;; arguments handler expects.
 166 (defun internal-error-args-ok (arguments handler)
 167   (multiple-value-bind (llks req opt)
 168       (parse-lambda-list (%simple-fun-arglist handler) :silent t)
 169     (declare (ignore llks))
 170     (let ((n (length arguments))
 171           (n-req (length req))
 172           (n-opt (length opt)))
 173       (and (>= n n-req) (<= n (+ n-req n-opt))))))
 174
 175 ;;;; INTERNAL-ERROR signal handler
 176
 177 ;;; Backtrace code may want to know the error that caused
 178 ;;; interruption, but there are other means to get code interrupted
 179 ;;; and inspecting code around PC for the error number may yield wrong
 180 ;;; results.
 181 (defvar *current-internal-error* nil)
 182
 183 ;;; This is needed for restarting XEPs, which do not bind anything but
 184 ;;; also do not save their own BSP, and we need to discard the
 185 ;;; bindings made by the error handling machinery.
 186 #!+unwind-to-frame-and-call-vop
 187 (defvar *interr-current-bsp* nil)
 188
 189 (defun internal-error (context continuable)
 190   (declare (type system-area-pointer context))
 191   (declare (ignore continuable))
 192   (/show0 "entering INTERNAL-ERROR, CONTEXT=..")
 193   (/hexstr context)
 194   (let (#!+unwind-to-frame-and-call-vop
 195         (*interr-current-bsp*
 196           ;; Needs to be done before anything is bound
 197           (%primitive sb!c:current-binding-pointer)))
 198    (infinite-error-protect
 199     (/show0 "about to bind ALIEN-CONTEXT")
 200     (let* ((alien-context (sap-alien context (* os-context-t)))
 201            #!+c-stack-is-control-stack
 202            (fp-and-pc (make-array 2 :element-type 'word)))
 203       #!+c-stack-is-control-stack
 204       (declare (truly-dynamic-extent fp-and-pc))
 205       #!+c-stack-is-control-stack
 206       (setf (aref fp-and-pc 0) (sb!vm:context-register alien-context sb!vm::cfp-offset)
 207             (aref fp-and-pc 1) (sb!sys:sap-int (sb!vm:context-pc alien-context)))
 208       (let (#!+c-stack-is-control-stack
 209             (*saved-fp-and-pcs* (cons fp-and-pc *saved-fp-and-pcs*)))
 210         #!+c-stack-is-control-stack
 211         (declare (truly-dynamic-extent *saved-fp-and-pcs*))
 212        (/show0 "about to bind ERROR-NUMBER and ARGUMENTS"))
 213       (multiple-value-bind (error-number arguments)
 214           (sb!vm:internal-error-args alien-context)
 215         (with-interrupt-bindings
 216           (let ((sb!debug:*stack-top-hint* (find-interrupted-frame))
 217                 (*current-internal-error* error-number)
 218                 (fp (int-sap (sb!vm:context-register alien-context
 219                                                      sb!vm::cfp-offset))))
 220             (if (and (>= error-number (length **internal-error-handlers**))
 221                      (< error-number (length sb!c:+backend-internal-errors+)))
 222                 (error 'type-error
 223                        :datum (sb!di::sub-access-debug-var-slot
 224                                fp (first arguments) alien-context)
 225                        :expected-type
 226                        (car (svref sb!c:+backend-internal-errors+
 227                                    error-number)))
 228                 (let ((handler
 229                         (and (typep error-number
 230                                     '#.`(mod ,(length **internal-error-handlers**)))
 231                              (svref **internal-error-handlers** error-number))))
 232                   (cond
 233                     ((and (functionp handler)
 234                           (internal-error-args-ok arguments handler))
 235                      (macrolet ((arg (n)
 236                                   `(sb!di::sub-access-debug-var-slot
 237                                     fp (nth ,n arguments) alien-context)))
 238                        (ecase (length arguments)
 239                          (0 (funcall handler))
 240                          (1 (funcall handler (arg 0)))
 241                          (2 (funcall handler (arg 0) (arg 1)))
 242                          (3 (funcall handler (arg 0) (arg 1) (arg 2))))))
 243                     ((eql handler 0) ; if (DEFERR x) was inadvertently omitted
 244                      (error 'simple-error
 245                             :format-control
 246                             "unknown internal error, ~D, args=~S"
 247                             :format-arguments
 248                             (list error-number
 249                                   (mapcar (lambda (sc-offset)
 250                                             (sb!di::sub-access-debug-var-slot
 251                                              fp sc-offset alien-context))
 252                                           arguments))))
 253                     (t                  ; wtf?
 254                      (error 'simple-error
 255                             :format-control "internal error ~D: ~A; args=~S"
 256                             :format-arguments
 257                             (list error-number
 258                                   handler
 259                                   (mapcar (lambda (sc-offset)
 260                                             (sb!di::sub-access-debug-var-slot
 261                                              fp sc-offset alien-context))
 262                                           arguments))))))))))))))
 263
 264 (defun control-stack-exhausted-error ()
 265   (let ((sb!debug:*stack-top-hint* nil))
 266     (infinite-error-protect
 267      (format *error-output*
 268              "Control stack guard page temporarily disabled: proceed with caution~%")
 269      (error 'control-stack-exhausted))))
 270
 271 (defun binding-stack-exhausted-error ()
 272   (let ((sb!debug:*stack-top-hint* nil))
 273     (infinite-error-protect
 274      (format *error-output*
 275              "Binding stack guard page temporarily disabled: proceed with caution~%")
 276      (error 'binding-stack-exhausted))))
 277
 278 (defun alien-stack-exhausted-error ()
 279   (let ((sb!debug:*stack-top-hint* nil))
 280     (infinite-error-protect
 281      (format *error-output*
 282              "Alien stack guard page temporarily disabled: proceed with caution~%")
 283      (error 'alien-stack-exhausted))))
 284
 285 ;;; KLUDGE: we keep a single HEAP-EXHAUSTED-ERROR object around, so
 286 ;;; that we don't need to allocate it when running out of
 287 ;;; memory. Similarly we pass the amounts in special variables as
 288 ;;; there may be multiple threads running into trouble at the same
 289 ;;; time. The condition is created by GC-REINIT.
 290 (defvar *heap-exhausted-error-condition*)
 291 (defvar *heap-exhausted-error-available-bytes*)
 292 (defvar *heap-exhausted-error-requested-bytes*)
 293
 294 (defun heap-exhausted-error (available requested)
 295   ;; Double word aligned bytes, can be passed as fixnums to avoid
 296   ;; allocating bignums on the C side.
 297   (declare (fixnum available requested))
 298   (infinite-error-protect
 299    (let ((*heap-exhausted-error-available-bytes*
 300            (ash available sb!vm:n-fixnum-tag-bits))
 301          (*heap-exhausted-error-requested-bytes*
 302            (ash requested sb!vm:n-fixnum-tag-bits)))
 303      (error *heap-exhausted-error-condition*))))
 304
 305 (defun undefined-alien-variable-error ()
 306   (declare (optimize allow-non-returning-tail-call))
 307   (error 'undefined-alien-variable-error))
 308
 309 #!-win32
 310 (define-alien-variable current-memory-fault-address unsigned)
 311
 312 #!-win32
 313 (defun memory-fault-error ()
 314   (let ((sb!debug:*stack-top-hint* (find-interrupted-frame)))
 315     (error 'memory-fault-error
 316            :address current-memory-fault-address)))
 317
 318 ;;; This is SIGTRAP / EXCEPTION_BREAKPOINT that runtime could not deal
 319 ;;; with. Prior to Windows we just had a Lisp side handler for
 320 ;;; SIGTRAP, but now we need to deal with this portably.
 321 (defun unhandled-trap-error (context-sap)
 322   (declare (type system-area-pointer context-sap))
 323   (infinite-error-protect
 324    (let ((context (sap-alien context-sap (* os-context-t))))
 325      (error 'breakpoint-error
 326             :context context
 327             :address (sap-int (sb!vm:context-pc context))))))