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