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 (defvar *internal-errors*
  18   #.(map 'vector #'cdr sb!c:*backend-internal-errors*))
  19
  20 (eval-when (:compile-toplevel :execute)
  21
  22 (sb!xc:defmacro deferr (name args &rest body)
  23   (let* ((rest-pos (position '&rest args))
  24          (required (if rest-pos (subseq args 0 rest-pos) args))
  25          (fp (gensym))
  26          (context (gensym))
  27          (sc-offsets (gensym))
  28          (fn-name (symbolicate name "-HANDLER")))
  29     `(progn
  30        ;; FIXME: Having a separate full DEFUN for each error doesn't
  31        ;; seem to add much value, and it takes a lot of space. Perhaps
  32        ;; we could do this dispatch with a big CASE statement instead?
  33        (defun ,fn-name (name ,fp ,context ,sc-offsets)
  34          ;; FIXME: Perhaps put in OPTIMIZE declaration to make this
  35          ;; byte coded.
  36          ;;
  37          ;; FIXME: It would probably be good to do *STACK-TOP-HINT*
  38          ;; tricks to hide this internal error-handling logic from the
  39          ;; poor high level user, so his debugger tells him about
  40          ;; where his error was detected instead of telling him where
  41          ;; he ended up inside the system error-handling logic.
  42          (declare (ignorable name ,fp ,context ,sc-offsets))
  43          (let (,@(let ((offset -1))
  44                    (mapcar #'(lambda (var)
  45                                `(,var (sb!di::sub-access-debug-var-slot
  46                                        ,fp
  47                                        (nth ,(incf offset)
  48                                             ,sc-offsets)
  49                                        ,context)))
  50                            required))
  51                ,@(when rest-pos
  52                    `((,(nth (1+ rest-pos) args)
  53                       (mapcar #'(lambda (sc-offset)
  54                                   (sb!di::sub-access-debug-var-slot
  55                                    ,fp
  56                                    sc-offset
  57                                    ,context))
  58                               (nthcdr ,rest-pos ,sc-offsets))))))
  59            ,@body))
  60        (setf (svref *internal-errors* ,(error-number-or-lose name))
  61              #',fn-name))))
  62
  63 ) ; EVAL-WHEN
  64
  65 (deferr unknown-error (&rest args)
  66   (error "unknown error:~{ ~S~})" args))
  67
  68 (deferr object-not-function-error (object)
  69   (error 'type-error
  70          :datum object
  71          :expected-type 'function))
  72
  73 (deferr object-not-list-error (object)
  74   (error 'type-error
  75          :datum object
  76          :expected-type 'list))
  77
  78 (deferr object-not-bignum-error (object)
  79   (error 'type-error
  80          :datum object
  81          :expected-type 'bignum))
  82
  83 (deferr object-not-ratio-error (object)
  84   (error 'type-error
  85          :datum object
  86          :expected-type 'ratio))
  87
  88 (deferr object-not-single-float-error (object)
  89   (error 'type-error
  90          :datum object
  91          :expected-type 'single-float))
  92
  93 (deferr object-not-double-float-error (object)
  94   (error 'type-error
  95          :datum object
  96          :expected-type 'double-float))
  97
  98 #!+long-float
  99 (deferr object-not-long-float-error (object)
 100   (error 'type-error
 101          :datum object
 102          :expected-type 'long-float))
 103
 104 (deferr object-not-simple-string-error (object)
 105   (error 'type-error
 106          :datum object
 107          :expected-type 'simple-string))
 108
 109 (deferr object-not-simple-bit-vector-error (object)
 110   (error 'type-error
 111          :datum object
 112          :expected-type 'simple-bit-vector))
 113
 114 (deferr object-not-simple-vector-error (object)
 115   (error 'type-error
 116          :datum object
 117          :expected-type 'simple-vector))
 118
 119 (deferr object-not-fixnum-error (object)
 120   (error 'type-error
 121          :datum object
 122          :expected-type 'fixnum))
 123
 124 (deferr object-not-function-or-symbol-error (object)
 125   (error 'type-error
 126          :datum object
 127          :expected-type '(or function symbol)))
 128
 129 (deferr object-not-vector-error (object)
 130   (error 'type-error
 131          :datum object
 132          :expected-type 'vector))
 133
 134 (deferr object-not-string-error (object)
 135   (error 'type-error
 136          :datum object
 137          :expected-type 'string))
 138
 139 (deferr object-not-bit-vector-error (object)
 140   (error 'type-error
 141          :datum object
 142          :expected-type 'bit-vector))
 143
 144 (deferr object-not-array-error (object)
 145   (error 'type-error
 146          :datum object
 147          :expected-type 'array))
 148
 149 (deferr object-not-number-error (object)
 150   (error 'type-error
 151          :datum object
 152          :expected-type 'number))
 153
 154 (deferr object-not-rational-error (object)
 155   (error 'type-error
 156          :datum object
 157          :expected-type 'rational))
 158
 159 (deferr object-not-float-error (object)
 160   (error 'type-error
 161          :datum object
 162          :expected-type 'float))
 163
 164 (deferr object-not-real-error (object)
 165   (error 'type-error
 166          :datum object
 167          :expected-type 'real))
 168
 169 (deferr object-not-integer-error (object)
 170   (error 'type-error
 171          :datum object
 172          :expected-type 'integer))
 173
 174 (deferr object-not-cons-error (object)
 175   (error 'type-error
 176          :datum object
 177          :expected-type 'cons))
 178
 179 (deferr object-not-symbol-error (object)
 180   (error 'type-error
 181          :datum object
 182          :expected-type 'symbol))
 183
 184 (deferr undefined-symbol-error (fdefn-or-symbol)
 185   (error 'undefined-function
 186          :name (etypecase fdefn-or-symbol
 187                  (symbol fdefn-or-symbol)
 188                  (fdefn (fdefn-name fdefn-or-symbol)))))
 189
 190 (deferr object-not-coerceable-to-function-error (object)
 191   (error 'type-error
 192          :datum object
 193          :expected-type 'coerceable-to-function))
 194
 195 (deferr invalid-argument-count-error (nargs)
 196   (error 'simple-program-error
 197          :format-control "invalid number of arguments: ~S"
 198          :format-arguments (list nargs)))
 199
 200 (deferr bogus-argument-to-values-list-error (list)
 201   (error 'simple-type-error
 202          :datum list
 203          :expected-type 'list
 204          :format-control
 205          "~@<attempt to use VALUES-LIST on a dotted list: ~2I~_~S~:>"
 206          :format-arguments (list list)))
 207
 208 (deferr unbound-symbol-error (symbol)
 209   (error 'unbound-variable :name symbol))
 210
 211 (deferr object-not-base-char-error (object)
 212   (error 'type-error
 213          :datum object
 214          :expected-type 'base-char))
 215
 216 (deferr object-not-sap-error (object)
 217   (error 'type-error
 218          :datum object
 219          :expected-type 'system-area-pointer))
 220
 221 (deferr invalid-unwind-error ()
 222   (error 'simple-control-error
 223          :format-control
 224          "attempt to RETURN-FROM a block or GO to a tag that no longer exists"
 225          ))
 226
 227 (deferr unseen-throw-tag-error (tag)
 228   (error 'simple-control-error
 229          :format-control "attempt to THROW to a tag that does not exist: ~S"
 230          :format-arguments (list tag)))
 231
 232 (deferr nil-function-returned-error (function)
 233   (error 'simple-control-error
 234          :format-control
 235          "A function with declared result type NIL returned:~%  ~S"
 236          :format-arguments (list function)))
 237
 238 (deferr division-by-zero-error (this that)
 239   (error 'division-by-zero
 240          :operation 'division
 241          :operands (list this that)))
 242
 243 (deferr object-not-type-error (object type)
 244   (error (if (and (typep object 'instance)
 245                   (layout-invalid (%instance-layout object)))
 246              'layout-invalid
 247              'type-error)
 248          :datum object
 249          :expected-type type))
 250
 251 (deferr layout-invalid-error (object layout)
 252   (error 'layout-invalid
 253          :datum object
 254          :expected-type (layout-class layout)))
 255
 256 (deferr odd-key-arguments-error ()
 257   (error 'simple-program-error
 258          :format-control "odd number of &KEY arguments"))
 259
 260 (deferr unknown-key-argument-error (key-name)
 261   (error 'simple-program-error
 262          :format-control "unknown &KEY argument: ~S"
 263          :format-arguments (list key-name)))
 264
 265 (deferr invalid-array-index-error (array bound index)
 266   (error 'simple-error
 267          :format-control
 268          "invalid array index ~D for ~S (should be nonnegative and <~D)"
 269          :format-arguments (list index array bound)))
 270
 271 (deferr object-not-simple-array-error (object)
 272   (error 'type-error
 273          :datum object
 274          :expected-type 'simple-array))
 275
 276 (deferr object-not-signed-byte-32-error (object)
 277   (error 'type-error
 278          :datum object
 279          :expected-type '(signed-byte 32)))
 280
 281 (deferr object-not-unsigned-byte-32-error (object)
 282   (error 'type-error
 283          :datum object
 284          :expected-type '(unsigned-byte 32)))
 285
 286 (deferr object-not-simple-array-unsigned-byte-2-error (object)
 287   (error 'type-error
 288          :datum object
 289          :expected-type '(simple-array (unsigned-byte 2) (*))))
 290
 291 (deferr object-not-simple-array-unsigned-byte-4-error (object)
 292   (error 'type-error
 293          :datum object
 294          :expected-type '(simple-array (unsigned-byte 4) (*))))
 295
 296 (deferr object-not-simple-array-unsigned-byte-8-error (object)
 297   (error 'type-error
 298          :datum object
 299          :expected-type '(simple-array (unsigned-byte 8) (*))))
 300
 301 (deferr object-not-simple-array-unsigned-byte-16-error (object)
 302   (error 'type-error
 303          :datum object
 304          :expected-type '(simple-array (unsigned-byte 16) (*))))
 305
 306 (deferr object-not-simple-array-unsigned-byte-32-error (object)
 307   (error 'type-error
 308          :datum object
 309          :expected-type '(simple-array (unsigned-byte 32) (*))))
 310
 311 (deferr object-not-simple-array-signed-byte-8-error (object)
 312   (error 'type-error
 313          :datum object
 314          :expected-type '(simple-array (signed-byte 8) (*))))
 315
 316 (deferr object-not-simple-array-signed-byte-16-error (object)
 317   (error 'type-error
 318          :datum object
 319          :expected-type '(simple-array (signed-byte 16) (*))))
 320
 321 (deferr object-not-simple-array-signed-byte-30-error (object)
 322   (error 'type-error
 323          :datum object
 324          :expected-type '(simple-array (signed-byte 30) (*))))
 325
 326 (deferr object-not-simple-array-signed-byte-32-error (object)
 327   (error 'type-error
 328          :datum object
 329          :expected-type '(simple-array (signed-byte 32) (*))))
 330
 331 (deferr object-not-simple-array-single-float-error (object)
 332   (error 'type-error
 333          :datum object
 334          :expected-type '(simple-array single-float (*))))
 335
 336 (deferr object-not-simple-array-double-float-error (object)
 337   (error 'type-error
 338          :datum object
 339          :expected-type '(simple-array double-float (*))))
 340
 341 (deferr object-not-simple-array-complex-single-float-error (object)
 342   (error 'type-error
 343          :datum object
 344          :expected-type '(simple-array (complex single-float) (*))))
 345
 346 (deferr object-not-simple-array-complex-double-float-error (object)
 347   (error 'type-error
 348          :datum object
 349          :expected-type '(simple-array (complex double-float) (*))))
 350
 351 #!+long-float
 352 (deferr object-not-simple-array-complex-long-float-error (object)
 353   (error 'type-error
 354          :datum object
 355          :expected-type '(simple-array (complex long-float) (*))))
 356
 357 (deferr object-not-complex-error (object)
 358   (error 'type-error
 359          :datum object
 360          :expected-type 'complex))
 361
 362 (deferr object-not-complex-rational-error (object)
 363   (error 'type-error
 364          :datum object
 365          :expected-type '(complex rational)))
 366
 367 (deferr object-not-complex-single-float-error (object)
 368   (error 'type-error
 369          :datum object
 370          :expected-type '(complex single-float)))
 371
 372 (deferr object-not-complex-double-float-error (object)
 373   (error 'type-error
 374          :datum object
 375          :expected-type '(complex double-float)))
 376
 377 #!+long-float
 378 (deferr object-not-complex-long-float-error (object)
 379   (error 'type-error
 380          :datum object
 381          :expected-type '(complex long-float)))
 382
 383 (deferr object-not-weak-pointer-error (object)
 384   (error 'type-error
 385          :datum object
 386          :expected-type 'weak-pointer))
 387
 388 (deferr object-not-instance-error (object)
 389   (error 'type-error
 390          :datum object
 391          :expected-type 'instance))
 392
 393 (deferr object-not-complex-vector-error (object)
 394   (error 'type-error
 395          :datum object
 396          :expected-type '(and vector (not simple-array))))
 397 \f
 398 ;;;; fetching errorful function name
 399
 400 ;;; This flag is used to prevent infinite recursive lossage when
 401 ;;; we can't find the caller for some reason.
 402 (defvar *finding-name* nil)
 403
 404 (defun find-caller-name-and-frame ()
 405   (if *finding-name*
 406       (values "<error finding caller name -- already finding name>" nil)
 407       (handler-case
 408           (let* ((*finding-name* t)
 409                  (frame (sb!di:frame-down (sb!di:frame-down (sb!di:top-frame))))
 410                  (name (sb!di:debug-function-name
 411                         (sb!di:frame-debug-function frame))))
 412             (sb!di:flush-frames-above frame)
 413             (values name frame))
 414         (error ()
 415           (values "<error finding caller name -- trapped error>" nil))
 416         (sb!di:debug-condition ()
 417           (values "<error finding caller name -- trapped debug-condition>"
 418                   nil)))))
 419
 420 (defun find-interrupted-name ()
 421   (if *finding-name*
 422       (values "<error finding interrupted name -- already finding name>" nil)
 423       (handler-case
 424           (let ((*finding-name* t))
 425             (do ((frame (sb!di:top-frame) (sb!di:frame-down frame)))
 426                 ((null frame)
 427                  (values "<error finding interrupted name -- null frame>" nil))
 428               (when (and (sb!di::compiled-frame-p frame)
 429                          (sb!di::compiled-frame-escaped frame))
 430                 (sb!di:flush-frames-above frame)
 431                 (return (values (sb!di:debug-function-name
 432                                  (sb!di:frame-debug-function frame))
 433                                 frame)))))
 434         (error ()
 435           (values "<error finding interrupted name -- trapped error>" nil))
 436         (sb!di:debug-condition ()
 437           (values "<error finding interrupted name -- trapped debug-condition>"
 438                   nil)))))
 439 \f
 440 ;;;; INTERNAL-ERROR signal handler
 441
 442 (defun internal-error (context continuable)
 443   (declare (type system-area-pointer context) (ignore continuable))
 444   (/show0 "entering INTERNAL-ERROR, CONTEXT=..")
 445   (/hexstr context)
 446   (infinite-error-protect
 447    (let ((context (locally
 448                     (declare (optimize (inhibit-warnings 3)))
 449                     (sb!alien:sap-alien context (* os-context-t)))))
 450      (multiple-value-bind (error-number arguments)
 451          (sb!vm:internal-error-arguments context)
 452        (multiple-value-bind (name sb!debug:*stack-top-hint*)
 453            (find-interrupted-name)
 454          (let ((fp (int-sap (sb!vm:context-register context
 455                                                     sb!vm::cfp-offset)))
 456                (handler (and (< -1 error-number (length *internal-errors*))
 457                              (svref *internal-errors* error-number))))
 458            (cond ((null handler)
 459                   (error 'simple-error
 460                          :format-control
 461                          "unknown internal error, ~D? args=~S"
 462                          :format-arguments
 463                          (list error-number
 464                                (mapcar #'(lambda (sc-offset)
 465                                            (sb!di::sub-access-debug-var-slot
 466                                             fp sc-offset context))
 467                                        arguments))))
 468                  ((not (functionp handler))
 469                   (error 'simple-error
 470                          :format-control "internal error ~D: ~A; args=~S"
 471                          :format-arguments
 472                          (list error-number
 473                                handler
 474                                (mapcar #'(lambda (sc-offset)
 475                                            (sb!di::sub-access-debug-var-slot
 476                                             fp sc-offset context))
 477                                        arguments))))
 478                  (t
 479                   (funcall handler name fp context arguments)))))))))