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