-
Notifications
You must be signed in to change notification settings - Fork 313
/
type-error.lisp
171 lines (160 loc) · 7.54 KB
/
type-error.lisp
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
;;;; generic error-call operations
;;;; This software is part of the SBCL system. See the README file for
;;;; more information.
;;;;
;;;; This software is derived from the CMU CL system, which was
;;;; written at Carnegie Mellon University and released into the
;;;; public domain. The software is in the public domain and is
;;;; provided with absolutely no warranty. See the COPYING and CREDITS
;;;; files for more information.
(in-package "SB-VM")
;;; (ARRAY NIL) stuff looks the same on all platforms
;;;
;;; This is separate from DATA-VECTOR-REF, because it's declared as
;;; unsafely-flushable, and flushing access to nil arrays causes all
;;; sorts of problems.
(define-vop (data-nil-vector-ref)
(:translate data-nil-vector-ref)
(:policy :fast-safe)
(:args (object :scs (descriptor-reg))
(index :scs (any-reg descriptor-reg) :load-if nil))
(:ignore index)
(:arg-types simple-array-nil *)
(:vop-var vop)
(:save-p :compute-only)
(:generator 1
(error-call vop 'nil-array-accessed-error object)))
;;; It shouldn't be possible to fall through to here in normal user
;;; code, as the system is smart enough to deduce that there must be
;;; an error upstream, as there are no objects of type NIL that can be
;;; stored in this data vector; however, just in case, we provide this
;;; translation, so that
;;; (LOCALLY
;;; (DECLARE (TYPE (SIMPLE-ARRAY NIL (*)) X)
;;; (OPTIMIZE (SPEED 3) (SAFETY 0)))
;;; (SB-KERNEL:DATA-VECTOR-SET X 3 'FOO))
;;; signals the right kind of error.
(define-vop (data-vector-set/simple-array-nil)
(:translate data-vector-set)
(:policy :fast-safe)
(:args (object :scs (descriptor-reg))
(index :scs (unsigned-reg))
(value :scs (descriptor-reg)))
(:arg-types simple-array-nil positive-fixnum *)
(:ignore index value)
(:vop-var vop)
(:save-p :compute-only)
(:generator 1
(error-call vop 'nil-array-accessed-error object)))
(define-vop (type-check-error/c)
(:policy :fast-safe)
(:translate sb-c::%type-check-error/c)
(:args (object :scs (descriptor-reg any-reg unsigned-reg signed-reg
character-reg constant)))
(:arg-types * (:constant symbol) (:constant t))
(:info errcode *location-context*)
(:vop-var vop)
(:save-p :compute-only)
(:generator 900
;; FIXME: this should be in the :elsewhere segment.
;; For lack of an architecture-independent way to emit
;; a jump, it's in the regular segment which pollutes the
;; instruction pipe with undecodable junk (the sc-numbers).
(error-call vop errcode object)))
#+(or immobile-space permgen) ; i.e. can LAYOUT instance have immediate SC
(defun type-err-type-tn-loadp (thing)
(cond ((sc-is thing immediate)
(let ((obj (tn-value thing)))
(typecase obj
(layout nil)
;; non-static symbols can be referenced as error-break args
;; because they appear in the code constants.
;; static symbols can't be referenced as error-break args
;; because there is no way to refer to an immediate value.
(symbol (static-symbol-p obj))
(t t))))
(t t)))
(macrolet ((def (error-name-prefix translate context &rest args)
(let* ((error (package-symbolicate "SB-KERNEL" error-name-prefix "-ERROR"))
(name (or translate error)))
`(define-vop (,name)
,@(when translate
`((:policy :fast-safe)
(:translate ,translate)))
(:args ,@(mapcar (lambda (arg)
`(,arg :scs (descriptor-reg any-reg character-reg
unsigned-reg signed-reg constant
single-reg double-reg
complex-single-reg complex-double-reg)
#+(or immobile-space permgen)
,@(if (eq name 'sb-c::%type-check-error)
`(:load-if (type-err-type-tn-loadp ,arg)))))
args))
,@(and context
`((:info *location-context*)
(:arg-types ,@(make-list (length args) :initial-element '*)
(:constant t))))
(:vop-var vop)
(:save-p :compute-only)
(:generator 1000
(error-call vop ',error ,@args))))))
(def "INVALID-ARG-COUNT" sb-c::%arg-count-error nil nargs)
(def "LOCAL-INVALID-ARG-COUNT" sb-c::%local-arg-count-error nil nargs fname)
(def "OBJECT-NOT-TYPE" sb-c::%type-check-error t object ptype)
(def "ODD-KEY-ARGS" sb-c::%odd-key-args-error nil)
(def "UNKNOWN-KEY-ARG" sb-c::%unknown-key-arg-error t key)
(def "ECASE-FAILURE" ecase-failure nil value keys)
(def "ETYPECASE-FAILURE" etypecase-failure nil value keys)
(def "NIL-FUN-RETURNED" nil-fun-returned-error nil fun)
(def "UNREACHABLE" sb-impl::unreachable nil)
(def "FAILED-AVER" sb-impl::%failed-aver nil form))
(defun emit-internal-error (kind code values &key trap-emitter)
(let ((trap-number (if (eq kind error-trap)
(+ kind code)
kind)))
(if trap-emitter
(funcall trap-emitter trap-number)
(inst byte trap-number)))
(unless (eq kind error-trap)
(inst byte code))
(encode-internal-error-args values))
(defvar *adjustable-vectors*)
(defmacro with-adjustable-vector ((var) &rest body)
`(let ((,var (or (pop *adjustable-vectors*)
(make-array 16
:element-type '(unsigned-byte 8)
:fill-pointer 0
:adjustable t))))
;; Don't declare the length - if it gets adjusted and pushed back
;; onto the freelist, it's anyone's guess whether it was expanded.
;; This code was wrong for >12 years, so nobody must have needed
;; more than 16 elements. Maybe we should make it nonadjustable?
(declare (type (vector (unsigned-byte 8)) ,var))
(setf (fill-pointer ,var) 0)
;; No UNWIND-PROTECT here - semantics are unaffected by nonlocal exit,
;; and this macro is about speeding up the compiler, not slowing it down.
;; GC will clean up any debris, and since the vector does not point
;; to anything, even an accidental promotion to a higher generation
;; will not cause transitive garbage retention.
(prog1 (progn ,@body)
(push ,var *adjustable-vectors*))))
(defun encode-internal-error-args (values)
(with-adjustable-vector (vector)
(dolist (where values)
(write-var-integer
;; WHERE can be either a TN or a packed SC number + offset
(cond ((consp where)
(make-sc+offset immediate-sc-number (car where)))
((not (tn-p where))
where)
((and (sc-is where immediate)
(fixnump (tn-value where)))
(make-sc+offset immediate-sc-number (tn-value where)))
(t
(make-sc+offset (if (and (sc-is where immediate)
(typep (tn-value where) '(or symbol layout)))
constant-sc-number
(sc-number (tn-sc where)))
(or (tn-offset where) 0))))
vector))
(loop for octet across vector do (inst byte octet))))