src/compiler/generic/type-error.lisp

   1 ;;;; generic error-call operations
   2
   3 ;;;; This software is part of the SBCL system. See the README file for
   4 ;;;; more information.
   5 ;;;;
   6 ;;;; This software is derived from the CMU CL system, which was
   7 ;;;; written at Carnegie Mellon University and released into the
   8 ;;;; public domain. The software is in the public domain and is
   9 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
  10 ;;;; files for more information.
  11 (in-package "SB!VM")
  12 \f
  13 ;;; (ARRAY NIL) stuff looks the same on all platforms
  14 ;;;
  15 ;;; This is separate from DATA-VECTOR-REF, because it's declared as
  16 ;;; unsafely-flushable, and flushing access to nil arrays causes all
  17 ;;; sorts of problems.
  18 (define-vop (data-nil-vector-ref)
  19   (:translate data-nil-vector-ref)
  20   (:policy :fast-safe)
  21   (:args (object :scs (descriptor-reg))
  22          (index :scs (any-reg descriptor-reg) :load-if nil))
  23   (:ignore index)
  24   (:arg-types simple-array-nil *)
  25   (:vop-var vop)
  26   (:save-p :compute-only)
  27   (:generator 1
  28     (error-call vop 'nil-array-accessed-error object)))
  29
  30 ;;; It shouldn't be possible to fall through to here in normal user
  31 ;;; code, as the system is smart enough to deduce that there must be
  32 ;;; an error upstream, as there are no objects of type NIL that can be
  33 ;;; stored in this data vector; however, just in case, we provide this
  34 ;;; translation, so that
  35 ;;;   (LOCALLY
  36 ;;;     (DECLARE (TYPE (SIMPLE-ARRAY NIL (*)) X)
  37 ;;;              (OPTIMIZE (SPEED 3) (SAFETY 0)))
  38 ;;;     (SB-KERNEL:DATA-VECTOR-SET X 3 'FOO))
  39 ;;; signals the right kind of error.
  40 (define-vop (data-vector-set/simple-array-nil)
  41   (:translate data-vector-set)
  42   (:policy :fast-safe)
  43   (:args (object :scs (descriptor-reg))
  44          (index :scs (unsigned-reg))
  45          (value :scs (descriptor-reg)))
  46   (:arg-types simple-array-nil positive-fixnum *)
  47   (:results (result :scs (descriptor-reg)))
  48   (:result-types *)
  49   (:ignore index value result)
  50   (:vop-var vop)
  51   (:save-p :compute-only)
  52   (:generator 1
  53     (error-call vop 'nil-array-accessed-error object)))
  54
  55 (define-vop (data-vector-set/simple-array-nil)
  56   (:translate data-vector-set)
  57   (:policy :fast-safe)
  58   (:args (object :scs (descriptor-reg))
  59          (index :scs (unsigned-reg))
  60          (value :scs (descriptor-reg)))
  61   (:info offset)
  62   (:arg-types simple-array-nil positive-fixnum *
  63               (:constant (integer 0 0)))
  64   (:results (result :scs (descriptor-reg)))
  65   (:result-types *)
  66   (:ignore index value result offset)
  67   (:vop-var vop)
  68   (:save-p :compute-only)
  69   (:generator 1
  70     (error-call vop 'nil-array-accessed-error object)))
  71
  72 (define-vop (type-check-error/c)
  73   (:policy :fast-safe)
  74   (:translate sb!c::%type-check-error/c)
  75   (:args (object :scs (descriptor-reg any-reg unsigned-reg signed-reg
  76                        character-reg constant)))
  77   (:arg-types * (:constant symbol) (:constant t))
  78   (:info errcode *location-context*)
  79   (:vop-var vop)
  80   (:save-p :compute-only)
  81   (:generator 900
  82     ;; FIXME: this should be in the *elsewhere* segment.
  83     ;; For lack of an architecture-independent way to emit
  84     ;; a jump, it's in the regular segment which pollutes the
  85     ;; instruction pipe with undecodable junk (the sc-numbers).
  86     (error-call vop errcode object)))
  87 \f
  88 (macrolet ((def (name error translate context &rest args)
  89              `(define-vop (,name)
  90                 ,@(when translate
  91                     `((:policy :fast-safe)
  92                       (:translate ,translate)))
  93                 (:args ,@(mapcar (lambda (arg)
  94                                    `(,arg :scs (descriptor-reg any-reg character-reg
  95                                                 unsigned-reg signed-reg constant)))
  96                                  args))
  97                 ,@(and context
  98                        `((:info *location-context*)
  99                          (:arg-types ,@(make-list (length args) :initial-element '*)
 100                                      (:constant t))))
 101                 (:vop-var vop)
 102                 (:save-p :compute-only)
 103                 (:generator 1000
 104                   (error-call vop ',error ,@args)))))
 105   (def arg-count-error invalid-arg-count-error
 106     sb!c::%arg-count-error nil nargs)
 107   (def local-arg-count-error local-invalid-arg-count-error
 108     sb!c::%local-arg-count-error nil nargs fname)
 109   (def type-check-error object-not-type-error sb!c::%type-check-error t
 110     object ptype)
 111   (def layout-invalid-error layout-invalid-error sb!c::%layout-invalid-error nil
 112     object layout)
 113   (def odd-key-args-error odd-key-args-error
 114     sb!c::%odd-key-args-error nil)
 115   (def unknown-key-arg-error unknown-key-arg-error
 116     sb!c::%unknown-key-arg-error t key)
 117   (def nil-fun-returned-error nil-fun-returned-error nil nil fun))
 118 \f
 119 (defun encode-internal-error-args (values)
 120   (with-adjustable-vector (vector)
 121     (dolist (where values)
 122       (write-var-integer
 123        ;; WHERE can be either a TN or a packed SC number + offset
 124        (if (tn-p where)
 125            (make-sc-offset (sc-number (tn-sc where)) (or (tn-offset where) 0))
 126            where)
 127        vector))
 128     (loop for octet across vector do (inst byte octet))))