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          (/show0 "about to do outer LETs in DEFERR macroexpanded DEFUN")
  44          (let (,@(let ((offset -1))
  45                    (mapcar #'(lambda (var)
  46                                `(,var (sb!di::sub-access-debug-var-slot
  47                                        ,fp
  48                                        (nth ,(incf offset)
  49                                             ,sc-offsets)
  50                                        ,context)))
  51                            required))
  52                ,@(when rest-pos
  53                    `((,(nth (1+ rest-pos) args)
  54                       (mapcar #'(lambda (sc-offset)
  55                                   (sb!di::sub-access-debug-var-slot
  56                                    ,fp
  57                                    sc-offset
  58                                    ,context))
  59                               (nthcdr ,rest-pos ,sc-offsets))))))
  60            ,@body))
  61        (setf (svref *internal-errors* ,(error-number-or-lose name))
  62              #',fn-name))))
  63
  64 ) ; EVAL-WHEN
  65
  66 (deferr unknown-error (&rest args)
  67   (error "unknown error:~{ ~S~})" args))
  68
  69 (deferr object-not-function-error (object)
  70   (error 'type-error
  71          :function-name name
  72          :datum object
  73          :expected-type 'function))
  74
  75 (deferr object-not-list-error (object)
  76   (error 'type-error
  77          :function-name name
  78          :datum object
  79          :expected-type 'list))
  80
  81 (deferr object-not-bignum-error (object)
  82   (error 'type-error
  83          :function-name name
  84          :datum object
  85          :expected-type 'bignum))
  86
  87 (deferr object-not-ratio-error (object)
  88   (error 'type-error
  89          :function-name name
  90          :datum object
  91          :expected-type 'ratio))
  92
  93 (deferr object-not-single-float-error (object)
  94   (error 'type-error
  95          :function-name name
  96          :datum object
  97          :expected-type 'single-float))
  98
  99 (deferr object-not-double-float-error (object)
 100   (error 'type-error
 101          :function-name name
 102          :datum object
 103          :expected-type 'double-float))
 104
 105 #!+long-float
 106 (deferr object-not-long-float-error (object)
 107   (error 'type-error
 108          :function-name name
 109          :datum object
 110          :expected-type 'long-float))
 111
 112 (deferr object-not-simple-string-error (object)
 113   (error 'type-error
 114          :function-name name
 115          :datum object
 116          :expected-type 'simple-string))
 117
 118 (deferr object-not-simple-bit-vector-error (object)
 119   (error 'type-error
 120          :function-name name
 121          :datum object
 122          :expected-type 'simple-bit-vector))
 123
 124 (deferr object-not-simple-vector-error (object)
 125   (error 'type-error
 126          :function-name name
 127          :datum object
 128          :expected-type 'simple-vector))
 129
 130 (deferr object-not-fixnum-error (object)
 131   (error 'type-error
 132          :function-name name
 133          :datum object
 134          :expected-type 'fixnum))
 135
 136 (deferr object-not-function-or-symbol-error (object)
 137   (error 'type-error
 138          :function-name name
 139          :datum object
 140          :expected-type '(or function symbol)))
 141
 142 (deferr object-not-vector-error (object)
 143   (error 'type-error
 144          :function-name name
 145          :datum object
 146          :expected-type 'vector))
 147
 148 (deferr object-not-string-error (object)
 149   (error 'type-error
 150          :function-name name
 151          :datum object
 152          :expected-type 'string))
 153
 154 (deferr object-not-bit-vector-error (object)
 155   (error 'type-error
 156          :function-name name
 157          :datum object
 158          :expected-type 'bit-vector))
 159
 160 (deferr object-not-array-error (object)
 161   (error 'type-error
 162          :function-name name
 163          :datum object
 164          :expected-type 'array))
 165
 166 (deferr object-not-number-error (object)
 167   (error 'type-error
 168          :function-name name
 169          :datum object
 170          :expected-type 'number))
 171
 172 (deferr object-not-rational-error (object)
 173   (error 'type-error
 174          :function-name name
 175          :datum object
 176          :expected-type 'rational))
 177
 178 (deferr object-not-float-error (object)
 179   (error 'type-error
 180          :function-name name
 181          :datum object
 182          :expected-type 'float))
 183
 184 (deferr object-not-real-error (object)
 185   (error 'type-error
 186          :function-name name
 187          :datum object
 188          :expected-type 'real))
 189
 190 (deferr object-not-integer-error (object)
 191   (error 'type-error
 192          :function-name name
 193          :datum object
 194          :expected-type 'integer))
 195
 196 (deferr object-not-cons-error (object)
 197   (error 'type-error
 198          :function-name name
 199          :datum object
 200          :expected-type 'cons))
 201
 202 (deferr object-not-symbol-error (object)
 203   (error 'type-error
 204          :function-name name
 205          :datum object
 206          :expected-type 'symbol))
 207
 208 (deferr undefined-symbol-error (fdefn-or-symbol)
 209   (error 'undefined-function
 210          :function-name name
 211          :name (etypecase fdefn-or-symbol
 212                  (symbol fdefn-or-symbol)
 213                  (fdefn (fdefn-name fdefn-or-symbol)))))
 214
 215 (deferr object-not-coerceable-to-function-error (object)
 216   (error 'type-error
 217          :function-name name
 218          :datum object
 219          :expected-type 'coerceable-to-function))
 220
 221 (deferr invalid-argument-count-error (nargs)
 222   (error 'simple-program-error
 223          :function-name name
 224          :format-control "invalid number of arguments: ~S"
 225          :format-arguments (list nargs)))
 226
 227 (deferr bogus-argument-to-values-list-error (list)
 228   (error 'simple-type-error
 229          :function-name name
 230          :datum list
 231          :expected-type 'list
 232          :format-control
 233          "~@<attempt to use VALUES-LIST on a dotted list: ~2I~_~S~:>"
 234          :format-arguments (list list)))
 235
 236 (deferr unbound-symbol-error (symbol)
 237   (error 'unbound-variable :function-name name :name symbol))
 238
 239 (deferr object-not-base-char-error (object)
 240   (error 'type-error
 241          :function-name name
 242          :datum object
 243          :expected-type 'base-char))
 244
 245 (deferr object-not-sap-error (object)
 246   (error 'type-error
 247          :function-name name
 248          :datum object
 249          :expected-type 'system-area-pointer))
 250
 251 (deferr invalid-unwind-error ()
 252   (error 'simple-control-error
 253          :function-name name
 254          :format-control
 255          "attempt to RETURN-FROM a block or GO to a tag that no longer exists"))
 256
 257 (deferr unseen-throw-tag-error (tag)
 258   (error 'simple-control-error
 259          :function-name name
 260          :format-control "attempt to THROW to a tag that does not exist: ~S"
 261          :format-arguments (list tag)))
 262
 263 (deferr nil-function-returned-error (function)
 264   (error 'simple-control-error
 265          :function-name name
 266          :format-control
 267          "A function with declared result type NIL returned:~%  ~S"
 268          :format-arguments (list function)))
 269
 270 (deferr division-by-zero-error (this that)
 271   (error 'division-by-zero
 272          :function-name name
 273          :operation 'division
 274          :operands (list this that)))
 275
 276 (deferr object-not-type-error (object type)
 277   (error (if (and (typep object 'instance)
 278                   (layout-invalid (%instance-layout object)))
 279              'layout-invalid
 280              'type-error)
 281          :function-name name
 282          :datum object
 283          :expected-type type))
 284
 285 (deferr layout-invalid-error (object layout)
 286   (error 'layout-invalid
 287          :function-name name
 288          :datum object
 289          :expected-type (layout-class layout)))
 290
 291 (deferr odd-keyword-arguments-error ()
 292   (error 'simple-program-error
 293          :function-name name
 294          :format-control "odd number of keyword arguments"))
 295
 296 (deferr unknown-keyword-argument-error (key)
 297   (error 'simple-program-error
 298          :function-name name
 299          :format-control "unknown keyword: ~S"
 300          :format-arguments (list key)))
 301
 302 (deferr invalid-array-index-error (array bound index)
 303   (error 'simple-error
 304          :function-name name
 305          :format-control
 306          "invalid array index ~D for ~S (should be nonnegative and <~D)"
 307          :format-arguments (list index array bound)))
 308
 309 (deferr object-not-simple-array-error (object)
 310   (error 'type-error
 311          :function-name name
 312          :datum object
 313          :expected-type 'simple-array))
 314
 315 (deferr object-not-signed-byte-32-error (object)
 316   (error 'type-error
 317          :function-name name
 318          :datum object
 319          :expected-type '(signed-byte 32)))
 320
 321 (deferr object-not-unsigned-byte-32-error (object)
 322   (error 'type-error
 323          :function-name name
 324          :datum object
 325          :expected-type '(unsigned-byte 32)))
 326
 327 (deferr object-not-simple-array-unsigned-byte-2-error (object)
 328   (error 'type-error
 329          :function-name name
 330          :datum object
 331          :expected-type '(simple-array (unsigned-byte 2) (*))))
 332
 333 (deferr object-not-simple-array-unsigned-byte-4-error (object)
 334   (error 'type-error
 335          :function-name name
 336          :datum object
 337          :expected-type '(simple-array (unsigned-byte 4) (*))))
 338
 339 (deferr object-not-simple-array-unsigned-byte-8-error (object)
 340   (error 'type-error
 341          :function-name name
 342          :datum object
 343          :expected-type '(simple-array (unsigned-byte 8) (*))))
 344
 345 (deferr object-not-simple-array-unsigned-byte-16-error (object)
 346   (error 'type-error
 347          :function-name name
 348          :datum object
 349          :expected-type '(simple-array (unsigned-byte 16) (*))))
 350
 351 (deferr object-not-simple-array-unsigned-byte-32-error (object)
 352   (error 'type-error
 353          :function-name name
 354          :datum object
 355          :expected-type '(simple-array (unsigned-byte 32) (*))))
 356
 357 (deferr object-not-simple-array-signed-byte-8-error (object)
 358   (error 'type-error
 359          :function-name name
 360          :datum object
 361          :expected-type '(simple-array (signed-byte 8) (*))))
 362
 363 (deferr object-not-simple-array-signed-byte-16-error (object)
 364   (error 'type-error
 365          :function-name name
 366          :datum object
 367          :expected-type '(simple-array (signed-byte 16) (*))))
 368
 369 (deferr object-not-simple-array-signed-byte-30-error (object)
 370   (error 'type-error
 371          :function-name name
 372          :datum object
 373          :expected-type '(simple-array (signed-byte 30) (*))))
 374
 375 (deferr object-not-simple-array-signed-byte-32-error (object)
 376   (error 'type-error
 377          :function-name name
 378          :datum object
 379          :expected-type '(simple-array (signed-byte 32) (*))))
 380
 381 (deferr object-not-simple-array-single-float-error (object)
 382   (error 'type-error
 383          :function-name name
 384          :datum object
 385          :expected-type '(simple-array single-float (*))))
 386
 387 (deferr object-not-simple-array-double-float-error (object)
 388   (error 'type-error
 389          :function-name name
 390          :datum object
 391          :expected-type '(simple-array double-float (*))))
 392
 393 (deferr object-not-simple-array-complex-single-float-error (object)
 394   (error 'type-error
 395          :function-name name
 396          :datum object
 397          :expected-type '(simple-array (complex single-float) (*))))
 398
 399 (deferr object-not-simple-array-complex-double-float-error (object)
 400   (error 'type-error
 401          :function-name name
 402          :datum object
 403          :expected-type '(simple-array (complex double-float) (*))))
 404
 405 #!+long-float
 406 (deferr object-not-simple-array-complex-long-float-error (object)
 407   (error 'type-error
 408          :function-name name
 409          :datum object
 410          :expected-type '(simple-array (complex long-float) (*))))
 411
 412 (deferr object-not-complex-error (object)
 413   (error 'type-error
 414          :function-name name
 415          :datum object
 416          :expected-type 'complex))
 417
 418 (deferr object-not-complex-rational-error (object)
 419   (error 'type-error
 420          :function-name name
 421          :datum object
 422          :expected-type '(complex rational)))
 423
 424 (deferr object-not-complex-single-float-error (object)
 425   (error 'type-error
 426          :function-name name
 427          :datum object
 428          :expected-type '(complex single-float)))
 429
 430 (deferr object-not-complex-double-float-error (object)
 431   (error 'type-error
 432          :function-name name
 433          :datum object
 434          :expected-type '(complex double-float)))
 435
 436 #!+long-float
 437 (deferr object-not-complex-long-float-error (object)
 438   (error 'type-error
 439          :function-name name
 440          :datum object
 441          :expected-type '(complex long-float)))
 442
 443 (deferr object-not-weak-pointer-error (object)
 444   (error 'type-error
 445          :function-name name
 446          :datum object
 447          :expected-type 'weak-pointer))
 448
 449 (deferr object-not-instance-error (object)
 450   (error 'type-error
 451          :function-name name
 452          :datum object
 453          :expected-type 'instance))
 454
 455 (deferr object-not-complex-vector-error (object)
 456   (error 'type-error
 457          :function-name name
 458          :datum object
 459          :expected-type '(and vector (not simple-array))))
 460 \f
 461 ;;;; fetching errorful function name
 462
 463 ;;; This variable is used to prevent infinite recursive lossage when
 464 ;;; we can't find the caller for some reason.
 465 (defvar *finding-name* nil)
 466
 467 (defun find-caller-name ()
 468   (if *finding-name*
 469       (values "<error finding caller name -- already finding name>" nil)
 470       (handler-case
 471           (let* ((*finding-name* t)
 472                  (frame (sb!di:frame-down (sb!di:frame-down (sb!di:top-frame))))
 473                  (name (sb!di:debug-function-name
 474                         (sb!di:frame-debug-function frame))))
 475             (sb!di:flush-frames-above frame)
 476             (values name frame))
 477         (error ()
 478           (values "<error finding caller name -- trapped error>" nil))
 479         (sb!di:debug-condition ()
 480           (values "<error finding caller name -- trapped debug-condition>"
 481                   nil)))))
 482
 483 (defun find-interrupted-name ()
 484   (if *finding-name*
 485       (values "<error finding interrupted name -- already finding name>" nil)
 486       (handler-case
 487           (let ((*finding-name* t))
 488             (do ((frame (sb!di:top-frame) (sb!di:frame-down frame)))
 489                 ((null frame)
 490                  (values "<error finding interrupted name -- null frame>" nil))
 491               (when (and (sb!di::compiled-frame-p frame)
 492                          (sb!di::compiled-frame-escaped frame))
 493                 (sb!di:flush-frames-above frame)
 494                 (return (values (sb!di:debug-function-name
 495                                  (sb!di:frame-debug-function frame))
 496                                 frame)))))
 497         (error ()
 498           (values "<error finding interrupted name -- trapped error>" nil))
 499         (sb!di:debug-condition ()
 500           (values "<error finding interrupted name -- trapped debug-condition>"
 501                   nil)))))
 502 \f
 503 ;;;; INTERNAL-ERROR signal handler
 504
 505 (defun internal-error (context continuable)
 506   (declare (type system-area-pointer context) (ignore continuable))
 507   (/show0 "entering INTERNAL-ERROR, CONTEXT=..")
 508   #!+sb-show (sb!sys:%primitive print (sb!impl::hexstr context))
 509   (infinite-error-protect
 510    (let ((context (locally
 511                     (declare (optimize (inhibit-warnings 3)))
 512                     (sb!alien:sap-alien context (* os-context-t)))))
 513      (multiple-value-bind (error-number arguments)
 514          (sb!vm:internal-error-arguments context)
 515        (multiple-value-bind (name sb!debug:*stack-top-hint*)
 516            (find-interrupted-name)
 517          (let ((fp (int-sap (sb!vm:context-register context
 518                                                     sb!vm::cfp-offset)))
 519                (handler (and (< -1 error-number (length *internal-errors*))
 520                              (svref *internal-errors* error-number))))
 521            (cond ((null handler)
 522                   (error 'simple-error
 523                          :function-name name
 524                          :format-control
 525                          "unknown internal error, ~D? args=~S"
 526                          :format-arguments
 527                          (list error-number
 528                                (mapcar #'(lambda (sc-offset)
 529                                            (sb!di::sub-access-debug-var-slot
 530                                             fp sc-offset context))
 531                                        arguments))))
 532                  ((not (functionp handler))
 533                   (error 'simple-error
 534                          :function-name name
 535                          :format-control "internal error ~D: ~A; args=~S"
 536                          :format-arguments
 537                          (list error-number
 538                                handler
 539                                (mapcar #'(lambda (sc-offset)
 540                                            (sb!di::sub-access-debug-var-slot
 541                                             fp sc-offset context))
 542                                        arguments))))
 543                  (t
 544                   (funcall handler name fp context arguments)))))))))