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 'type-error
 229          :function-name name
 230          :format-control "attempt to use VALUES-LIST on a dotted-list:~%  ~S"
 231          :format-arguments (list list)))
 232
 233 (deferr unbound-symbol-error (symbol)
 234   (error 'unbound-variable :function-name name :name symbol))
 235
 236 (deferr object-not-base-char-error (object)
 237   (error 'type-error
 238          :function-name name
 239          :datum object
 240          :expected-type 'base-char))
 241
 242 (deferr object-not-sap-error (object)
 243   (error 'type-error
 244          :function-name name
 245          :datum object
 246          :expected-type 'system-area-pointer))
 247
 248 (deferr invalid-unwind-error ()
 249   (error 'simple-control-error
 250          :function-name name
 251          :format-control
 252          "attempt to RETURN-FROM a block or GO to a tag that no longer exists"))
 253
 254 (deferr unseen-throw-tag-error (tag)
 255   (error 'simple-control-error
 256          :function-name name
 257          :format-control "attempt to THROW to a tag that does not exist: ~S"
 258          :format-arguments (list tag)))
 259
 260 (deferr nil-function-returned-error (function)
 261   (error 'simple-control-error
 262          :function-name name
 263          :format-control
 264          "A function with declared result type NIL returned:~%  ~S"
 265          :format-arguments (list function)))
 266
 267 (deferr division-by-zero-error (this that)
 268   (error 'division-by-zero
 269          :function-name name
 270          :operation 'division
 271          :operands (list this that)))
 272
 273 (deferr object-not-type-error (object type)
 274   (error (if (and (typep object 'instance)
 275                   (layout-invalid (%instance-layout object)))
 276              'layout-invalid
 277              'type-error)
 278          :function-name name
 279          :datum object
 280          :expected-type type))
 281
 282 (deferr layout-invalid-error (object layout)
 283   (error 'layout-invalid
 284          :function-name name
 285          :datum object
 286          :expected-type (layout-class layout)))
 287
 288 (deferr odd-keyword-arguments-error ()
 289   (error 'simple-program-error
 290          :function-name name
 291          :format-control "odd number of keyword arguments"))
 292
 293 (deferr unknown-keyword-argument-error (key)
 294   (error 'simple-program-error
 295          :function-name name
 296          :format-control "unknown keyword: ~S"
 297          :format-arguments (list key)))
 298
 299 (deferr invalid-array-index-error (array bound index)
 300   (error 'simple-error
 301          :function-name name
 302          :format-control
 303          "invalid array index ~D for ~S (should be nonnegative and <~D)"
 304          :format-arguments (list index array bound)))
 305
 306 (deferr object-not-simple-array-error (object)
 307   (error 'type-error
 308          :function-name name
 309          :datum object
 310          :expected-type 'simple-array))
 311
 312 (deferr object-not-signed-byte-32-error (object)
 313   (error 'type-error
 314          :function-name name
 315          :datum object
 316          :expected-type '(signed-byte 32)))
 317
 318 (deferr object-not-unsigned-byte-32-error (object)
 319   (error 'type-error
 320          :function-name name
 321          :datum object
 322          :expected-type '(unsigned-byte 32)))
 323
 324 (deferr object-not-simple-array-unsigned-byte-2-error (object)
 325   (error 'type-error
 326          :function-name name
 327          :datum object
 328          :expected-type '(simple-array (unsigned-byte 2) (*))))
 329
 330 (deferr object-not-simple-array-unsigned-byte-4-error (object)
 331   (error 'type-error
 332          :function-name name
 333          :datum object
 334          :expected-type '(simple-array (unsigned-byte 4) (*))))
 335
 336 (deferr object-not-simple-array-unsigned-byte-8-error (object)
 337   (error 'type-error
 338          :function-name name
 339          :datum object
 340          :expected-type '(simple-array (unsigned-byte 8) (*))))
 341
 342 (deferr object-not-simple-array-unsigned-byte-16-error (object)
 343   (error 'type-error
 344          :function-name name
 345          :datum object
 346          :expected-type '(simple-array (unsigned-byte 16) (*))))
 347
 348 (deferr object-not-simple-array-unsigned-byte-32-error (object)
 349   (error 'type-error
 350          :function-name name
 351          :datum object
 352          :expected-type '(simple-array (unsigned-byte 32) (*))))
 353
 354 (deferr object-not-simple-array-signed-byte-8-error (object)
 355   (error 'type-error
 356          :function-name name
 357          :datum object
 358          :expected-type '(simple-array (signed-byte 8) (*))))
 359
 360 (deferr object-not-simple-array-signed-byte-16-error (object)
 361   (error 'type-error
 362          :function-name name
 363          :datum object
 364          :expected-type '(simple-array (signed-byte 16) (*))))
 365
 366 (deferr object-not-simple-array-signed-byte-30-error (object)
 367   (error 'type-error
 368          :function-name name
 369          :datum object
 370          :expected-type '(simple-array (signed-byte 30) (*))))
 371
 372 (deferr object-not-simple-array-signed-byte-32-error (object)
 373   (error 'type-error
 374          :function-name name
 375          :datum object
 376          :expected-type '(simple-array (signed-byte 32) (*))))
 377
 378 (deferr object-not-simple-array-single-float-error (object)
 379   (error 'type-error
 380          :function-name name
 381          :datum object
 382          :expected-type '(simple-array single-float (*))))
 383
 384 (deferr object-not-simple-array-double-float-error (object)
 385   (error 'type-error
 386          :function-name name
 387          :datum object
 388          :expected-type '(simple-array double-float (*))))
 389
 390 (deferr object-not-simple-array-complex-single-float-error (object)
 391   (error 'type-error
 392          :function-name name
 393          :datum object
 394          :expected-type '(simple-array (complex single-float) (*))))
 395
 396 (deferr object-not-simple-array-complex-double-float-error (object)
 397   (error 'type-error
 398          :function-name name
 399          :datum object
 400          :expected-type '(simple-array (complex double-float) (*))))
 401
 402 #!+long-float
 403 (deferr object-not-simple-array-complex-long-float-error (object)
 404   (error 'type-error
 405          :function-name name
 406          :datum object
 407          :expected-type '(simple-array (complex long-float) (*))))
 408
 409 (deferr object-not-complex-error (object)
 410   (error 'type-error
 411          :function-name name
 412          :datum object
 413          :expected-type 'complex))
 414
 415 (deferr object-not-complex-rational-error (object)
 416   (error 'type-error
 417          :function-name name
 418          :datum object
 419          :expected-type '(complex rational)))
 420
 421 (deferr object-not-complex-single-float-error (object)
 422   (error 'type-error
 423          :function-name name
 424          :datum object
 425          :expected-type '(complex single-float)))
 426
 427 (deferr object-not-complex-double-float-error (object)
 428   (error 'type-error
 429          :function-name name
 430          :datum object
 431          :expected-type '(complex double-float)))
 432
 433 #!+long-float
 434 (deferr object-not-complex-long-float-error (object)
 435   (error 'type-error
 436          :function-name name
 437          :datum object
 438          :expected-type '(complex long-float)))
 439
 440 (deferr object-not-weak-pointer-error (object)
 441   (error 'type-error
 442          :function-name name
 443          :datum object
 444          :expected-type 'weak-pointer))
 445
 446 (deferr object-not-instance-error (object)
 447   (error 'type-error
 448          :function-name name
 449          :datum object
 450          :expected-type 'instance))
 451 \f
 452 ;;;; fetching errorful function name
 453
 454 ;;; This variable is used to prevent infinite recursive lossage when
 455 ;;; we can't find the caller for some reason.
 456 (defvar *finding-name* nil)
 457
 458 (defun find-caller-name ()
 459   (if *finding-name*
 460       (values "<error finding caller name -- already finding name>" nil)
 461       (handler-case
 462           (let* ((*finding-name* t)
 463                  (frame (sb!di:frame-down (sb!di:frame-down (sb!di:top-frame))))
 464                  (name (sb!di:debug-function-name
 465                         (sb!di:frame-debug-function frame))))
 466             (sb!di:flush-frames-above frame)
 467             (values name frame))
 468         (error ()
 469           (values "<error finding caller name -- trapped error>" nil))
 470         (sb!di:debug-condition ()
 471           (values "<error finding caller name -- trapped debug-condition>"
 472                   nil)))))
 473
 474 (defun find-interrupted-name ()
 475   (if *finding-name*
 476       (values "<error finding interrupted name -- already finding name>" nil)
 477       (handler-case
 478           (let ((*finding-name* t))
 479             (do ((frame (sb!di:top-frame) (sb!di:frame-down frame)))
 480                 ((null frame)
 481                  (values "<error finding interrupted name -- null frame>" nil))
 482               (when (and (sb!di::compiled-frame-p frame)
 483                          (sb!di::compiled-frame-escaped frame))
 484                 (sb!di:flush-frames-above frame)
 485                 (return (values (sb!di:debug-function-name
 486                                  (sb!di:frame-debug-function frame))
 487                                 frame)))))
 488         (error ()
 489           (values "<error finding interrupted name -- trapped error>" nil))
 490         (sb!di:debug-condition ()
 491           (values "<error finding interrupted name -- trapped debug-condition>"
 492                   nil)))))
 493 \f
 494 ;;;; INTERNAL-ERROR signal handler
 495
 496 (defun internal-error (context continuable)
 497   (declare (type system-area-pointer context) (ignore continuable))
 498   (/show0 "entering INTERNAL-ERROR, CONTEXT=..")
 499   #!+sb-show (sb!sys:%primitive print (sb!impl::hexstr context))
 500   (infinite-error-protect
 501    (let ((context (locally
 502                     (declare (optimize (inhibit-warnings 3)))
 503                     (sb!alien:sap-alien context (* os-context-t)))))
 504      (multiple-value-bind (error-number arguments)
 505          (sb!vm:internal-error-arguments context)
 506        (multiple-value-bind (name sb!debug:*stack-top-hint*)
 507            (find-interrupted-name)
 508          (let ((fp (int-sap (sb!vm:context-register context
 509                                                     sb!vm::cfp-offset)))
 510                (handler (and (< -1 error-number (length *internal-errors*))
 511                              (svref *internal-errors* error-number))))
 512            (cond ((null handler)
 513                   (error 'simple-error
 514                          :function-name name
 515                          :format-control
 516                          "unknown internal error, ~D? args=~S"
 517                          :format-arguments
 518                          (list error-number
 519                                (mapcar #'(lambda (sc-offset)
 520                                            (sb!di::sub-access-debug-var-slot
 521                                             fp sc-offset context))
 522                                        arguments))))
 523                  ((not (functionp handler))
 524                   (error 'simple-error
 525                          :function-name name
 526                          :format-control "internal error ~D: ~A; args=~S"
 527                          :format-arguments
 528                          (list error-number
 529                                handler
 530                                (mapcar #'(lambda (sc-offset)
 531                                            (sb!di::sub-access-debug-var-slot
 532                                             fp sc-offset context))
 533                                        arguments))))
 534                  (t
 535                   (funcall handler name fp context arguments)))))))))