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