4 ;;;; Simple type checking and testing:
6 ;;; These types are represented by a single type code, so are easily
7 ;;; open-coded as a mask and compare.
9 (define-vop (check-type)
10 (:args (value :target result :scs (any-reg descriptor-reg)))
11 (:results (result :scs (any-reg descriptor-reg)))
12 (:temporary (:scs (non-descriptor-reg)) temp)
14 (:save-p :compute-only))
16 (define-vop (type-predicate)
17 (:args (value :scs (any-reg descriptor-reg)))
21 (:temporary (:scs (non-descriptor-reg)) temp))
23 (eval-when (:compile-toplevel :load-toplevel)
24 (defun cost-to-test-types (type-codes)
25 (+ (* 2 (length type-codes))
26 (if (> (apply #'max type-codes) lowtag-limit) 7 2))))
28 (macrolet ((def-type-vops (pred-name check-name ptype error-code
30 (let ((cost (cost-to-test-types (mapcar #'eval type-codes))))
33 `((define-vop (,pred-name type-predicate)
34 (:translate ,pred-name)
36 (test-type value temp target not-p ,@type-codes)))))
38 `((define-vop (,check-name check-type)
41 (generate-error-code vop ,error-code value)))
42 (test-type value temp err-lab t ,@type-codes)
43 (move result value))))))
45 `((primitive-type-vop ,check-name (:check) ,ptype)))))))
47 (def-type-vops fixnump nil nil object-not-fixnum-error
48 sb!vm:even-fixnum-lowtag sb!vm:odd-fixnum-lowtag)
49 (define-vop (check-fixnum check-type)
51 (inst andi. temp value 3)
52 (inst twi 0 value (error-number-or-lose 'object-not-fixnum-error))
55 (primitive-type-vop check-fixnum (:check) fixnum)
56 (def-type-vops functionp nil nil
57 object-not-fun-error sb!vm:fun-pointer-lowtag)
59 (define-vop (check-fun check-type)
61 (inst andi. temp value 7)
62 (inst twi 0 value (error-number-or-lose 'object-not-fun-error))
63 (inst twi :ne temp sb!vm:fun-pointer-lowtag)
65 (primitive-type-vop check-fun (:check) function)
67 (def-type-vops listp nil nil
68 object-not-list-error sb!vm:list-pointer-lowtag)
69 (define-vop (check-list check-type)
71 (inst andi. temp value 7)
72 (inst twi 0 value (error-number-or-lose 'object-not-list-error))
73 (inst twi :ne temp sb!vm:list-pointer-lowtag)
75 (primitive-type-vop check-list (:check) list)
77 (def-type-vops %instancep nil nil
78 object-not-instance-error sb!vm:instance-pointer-lowtag)
79 (define-vop (check-instance check-type)
81 (inst andi. temp value 7)
82 (inst twi 0 value (error-number-or-lose 'object-not-instance-error))
83 (inst twi :ne temp sb!vm:instance-pointer-lowtag)
85 (primitive-type-vop check-instance (:check) instance)
88 (def-type-vops bignump check-bignum bignum
89 object-not-bignum-error sb!vm:bignum-widetag)
91 (def-type-vops ratiop check-ratio ratio
92 object-not-ratio-error sb!vm:ratio-widetag)
94 (def-type-vops complexp check-complex complex
95 object-not-complex-error sb!vm:complex-widetag
96 complex-single-float-widetag complex-double-float-widetag)
98 (def-type-vops complex-rational-p check-complex-rational nil
99 object-not-complex-rational-error complex-widetag)
101 (def-type-vops complex-float-p check-complex-float nil
102 object-not-complex-float-error
103 complex-single-float-widetag complex-double-float-widetag)
105 (def-type-vops complex-single-float-p check-complex-single-float
106 complex-single-float object-not-complex-single-float-error
107 complex-single-float-widetag)
109 (def-type-vops complex-double-float-p check-complex-double-float
110 complex-double-float object-not-complex-double-float-error
111 complex-double-float-widetag)
113 (def-type-vops single-float-p check-single-float single-float
114 object-not-single-float-error sb!vm:single-float-widetag)
116 (def-type-vops double-float-p check-double-float double-float
117 object-not-double-float-error sb!vm:double-float-widetag)
119 (def-type-vops simple-string-p check-simple-string simple-string
120 object-not-simple-string-error sb!vm:simple-string-widetag)
122 (def-type-vops simple-bit-vector-p check-simple-bit-vector simple-bit-vector
123 object-not-simple-bit-vector-error simple-bit-vector-widetag)
125 (def-type-vops simple-vector-p check-simple-vector simple-vector
126 object-not-simple-vector-error sb!vm:simple-vector-widetag)
128 (def-type-vops simple-array-unsigned-byte-2-p
129 check-simple-array-unsigned-byte-2
130 simple-array-unsigned-byte-2
131 object-not-simple-array-unsigned-byte-2-error
132 sb!vm:simple-array-unsigned-byte-2-widetag)
134 (def-type-vops simple-array-unsigned-byte-4-p
135 check-simple-array-unsigned-byte-4
136 simple-array-unsigned-byte-4
137 object-not-simple-array-unsigned-byte-4-error
138 sb!vm:simple-array-unsigned-byte-4-widetag)
140 (def-type-vops simple-array-unsigned-byte-8-p
141 check-simple-array-unsigned-byte-8
142 simple-array-unsigned-byte-8
143 object-not-simple-array-unsigned-byte-8-error
144 sb!vm:simple-array-unsigned-byte-8-widetag)
146 (def-type-vops simple-array-unsigned-byte-16-p
147 check-simple-array-unsigned-byte-16
148 simple-array-unsigned-byte-16
149 object-not-simple-array-unsigned-byte-16-error
150 sb!vm:simple-array-unsigned-byte-16-widetag)
152 (def-type-vops simple-array-unsigned-byte-32-p
153 check-simple-array-unsigned-byte-32
154 simple-array-unsigned-byte-32
155 object-not-simple-array-unsigned-byte-32-error
156 sb!vm:simple-array-unsigned-byte-32-widetag)
158 (def-type-vops simple-array-signed-byte-8-p
159 check-simple-array-signed-byte-8
160 simple-array-signed-byte-8
161 object-not-simple-array-signed-byte-8-error
162 simple-array-signed-byte-8-widetag)
164 (def-type-vops simple-array-signed-byte-16-p
165 check-simple-array-signed-byte-16
166 simple-array-signed-byte-16
167 object-not-simple-array-signed-byte-16-error
168 simple-array-signed-byte-16-widetag)
170 (def-type-vops simple-array-signed-byte-30-p
171 check-simple-array-signed-byte-30
172 simple-array-signed-byte-30
173 object-not-simple-array-signed-byte-30-error
174 simple-array-signed-byte-30-widetag)
176 (def-type-vops simple-array-signed-byte-32-p
177 check-simple-array-signed-byte-32
178 simple-array-signed-byte-32
179 object-not-simple-array-signed-byte-32-error
180 simple-array-signed-byte-32-widetag)
182 (def-type-vops simple-array-single-float-p check-simple-array-single-float
183 simple-array-single-float object-not-simple-array-single-float-error
184 sb!vm:simple-array-single-float-widetag)
186 (def-type-vops simple-array-double-float-p check-simple-array-double-float
187 simple-array-double-float object-not-simple-array-double-float-error
188 sb!vm:simple-array-double-float-widetag)
190 (def-type-vops simple-array-complex-single-float-p
191 check-simple-array-complex-single-float
192 simple-array-complex-single-float
193 object-not-simple-array-complex-single-float-error
194 simple-array-complex-single-float-widetag)
196 (def-type-vops simple-array-complex-double-float-p
197 check-simple-array-complex-double-float
198 simple-array-complex-double-float
199 object-not-simple-array-complex-double-float-error
200 simple-array-complex-double-float-widetag)
202 (def-type-vops base-char-p check-base-char base-char
203 object-not-base-char-error sb!vm:base-char-widetag)
205 (def-type-vops system-area-pointer-p check-system-area-pointer
206 system-area-pointer object-not-sap-error sb!vm:sap-widetag)
208 (def-type-vops weak-pointer-p check-weak-pointer weak-pointer
209 object-not-weak-pointer-error sb!vm:weak-pointer-widetag)
211 (def-type-vops code-component-p nil nil nil
212 sb!vm:code-header-widetag)
214 (def-type-vops lra-p nil nil nil
215 sb!vm:return-pc-header-widetag)
217 (def-type-vops fdefn-p nil nil nil
220 (def-type-vops funcallable-instance-p nil nil nil
221 sb!vm:funcallable-instance-header-widetag)
223 (def-type-vops array-header-p nil nil nil
224 sb!vm:simple-array-widetag sb!vm:complex-string-widetag sb!vm:complex-bit-vector-widetag
225 sb!vm:complex-vector-widetag sb!vm:complex-array-widetag)
227 (def-type-vops nil check-function-or-symbol nil object-not-function-or-symbol-error
228 sb!vm:fun-pointer-lowtag sb!vm:symbol-header-widetag)
230 (def-type-vops stringp check-string nil object-not-string-error
231 sb!vm:simple-string-widetag sb!vm:complex-string-widetag)
233 (def-type-vops complex-vector-p check-complex-vector nil
234 object-not-complex-vector-error complex-vector-widetag)
236 (def-type-vops bit-vector-p check-bit-vector nil object-not-bit-vector-error
237 sb!vm:simple-bit-vector-widetag sb!vm:complex-bit-vector-widetag)
239 (def-type-vops vectorp check-vector nil object-not-vector-error
240 simple-string-widetag simple-bit-vector-widetag simple-vector-widetag
241 simple-array-unsigned-byte-2-widetag simple-array-unsigned-byte-4-widetag
242 simple-array-unsigned-byte-8-widetag simple-array-unsigned-byte-16-widetag
243 simple-array-unsigned-byte-32-widetag
244 simple-array-signed-byte-8-widetag simple-array-signed-byte-16-widetag
245 simple-array-signed-byte-30-widetag simple-array-signed-byte-32-widetag
246 simple-array-single-float-widetag simple-array-double-float-widetag
247 simple-array-complex-single-float-widetag
248 simple-array-complex-double-float-widetag
249 complex-string-widetag complex-bit-vector-widetag complex-vector-widetag)
251 (def-type-vops simple-array-p check-simple-array nil object-not-simple-array-error
252 simple-array-widetag simple-string-widetag simple-bit-vector-widetag
253 simple-vector-widetag simple-array-unsigned-byte-2-widetag
254 simple-array-unsigned-byte-4-widetag simple-array-unsigned-byte-8-widetag
255 simple-array-unsigned-byte-16-widetag simple-array-unsigned-byte-32-widetag
256 simple-array-signed-byte-8-widetag simple-array-signed-byte-16-widetag
257 simple-array-signed-byte-30-widetag simple-array-signed-byte-32-widetag
258 simple-array-single-float-widetag simple-array-double-float-widetag
259 simple-array-complex-single-float-widetag
260 simple-array-complex-double-float-widetag)
262 (def-type-vops arrayp check-array nil object-not-array-error
263 simple-array-widetag simple-string-widetag simple-bit-vector-widetag
264 simple-vector-widetag simple-array-unsigned-byte-2-widetag
265 simple-array-unsigned-byte-4-widetag simple-array-unsigned-byte-8-widetag
266 simple-array-unsigned-byte-16-widetag simple-array-unsigned-byte-32-widetag
267 simple-array-signed-byte-8-widetag simple-array-signed-byte-16-widetag
268 simple-array-signed-byte-30-widetag simple-array-signed-byte-32-widetag
269 simple-array-single-float-widetag simple-array-double-float-widetag
270 simple-array-complex-single-float-widetag
271 simple-array-complex-double-float-widetag
272 complex-string-widetag complex-bit-vector-widetag complex-vector-widetag
273 complex-array-widetag)
275 (def-type-vops numberp check-number nil object-not-number-error
276 even-fixnum-lowtag odd-fixnum-lowtag bignum-widetag ratio-widetag
277 single-float-widetag double-float-widetag complex-widetag
278 complex-single-float-widetag complex-double-float-widetag)
280 (def-type-vops rationalp check-rational nil object-not-rational-error
281 sb!vm:even-fixnum-lowtag sb!vm:odd-fixnum-lowtag sb!vm:ratio-widetag sb!vm:bignum-widetag)
283 (def-type-vops integerp check-integer nil object-not-integer-error
284 sb!vm:even-fixnum-lowtag sb!vm:odd-fixnum-lowtag sb!vm:bignum-widetag)
286 (def-type-vops floatp check-float nil object-not-float-error
287 sb!vm:single-float-widetag sb!vm:double-float-widetag)
289 (def-type-vops realp check-real nil object-not-real-error
290 sb!vm:even-fixnum-lowtag sb!vm:odd-fixnum-lowtag sb!vm:ratio-widetag sb!vm:bignum-widetag
291 sb!vm:single-float-widetag sb!vm:double-float-widetag))
294 ;;;; Other integer ranges.
296 ;;; A (signed-byte 32) can be represented with either fixnum or a bignum with
297 ;;; exactly one digit.
299 (define-vop (signed-byte-32-p type-predicate)
300 (:translate signed-byte-32-p)
302 (let ((not-target (gen-label)))
306 (values not-target target)
307 (values target not-target))
308 (inst andi. temp value #x3)
310 (test-type value temp nope t sb!vm:other-pointer-lowtag)
311 (loadw temp value 0 sb!vm:other-pointer-lowtag)
312 (inst cmpwi temp (+ (ash 1 sb!vm:n-widetag-bits)
313 sb!vm:bignum-widetag))
314 (inst b? (if not-p :ne :eq) target)
315 (emit-label not-target)))))
317 (define-vop (check-signed-byte-32 check-type)
319 (let ((nope (generate-error-code vop object-not-signed-byte-32-error value))
321 (inst andi. temp value #x3)
323 (test-type value temp nope t sb!vm:other-pointer-lowtag)
324 (loadw temp value 0 sb!vm:other-pointer-lowtag)
325 (inst cmpwi temp (+ (ash 1 sb!vm:n-widetag-bits) sb!vm:bignum-widetag))
328 (move result value))))
331 ;;; An (unsigned-byte 32) can be represented with either a positive fixnum, a
332 ;;; bignum with exactly one positive digit, or a bignum with exactly two digits
333 ;;; and the second digit all zeros.
335 (define-vop (unsigned-byte-32-p type-predicate)
336 (:translate unsigned-byte-32-p)
338 (let ((not-target (gen-label))
339 (single-word (gen-label))
340 (fixnum (gen-label)))
344 (values not-target target)
345 (values target not-target))
347 (inst andi. temp value #x3)
348 (inst cmpwi :cr1 value 0)
351 ;; If not, is it an other pointer?
352 (test-type value temp nope t sb!vm:other-pointer-lowtag)
354 (loadw temp value 0 sb!vm:other-pointer-lowtag)
356 (inst cmpwi temp (+ (ash 1 sb!vm:n-widetag-bits) sb!vm:bignum-widetag))
357 (inst beq single-word)
358 ;; If it's other than two, we can't be an (unsigned-byte 32)
359 (inst cmpwi temp (+ (ash 2 sb!vm:n-widetag-bits) sb!vm:bignum-widetag))
361 ;; Get the second digit.
362 (loadw temp value (1+ sb!vm:bignum-digits-offset) sb!vm:other-pointer-lowtag)
363 ;; All zeros, its an (unsigned-byte 32).
366 ;; Otherwise, it isn't.
369 (emit-label single-word)
370 ;; Get the single digit.
371 (loadw temp value sb!vm:bignum-digits-offset sb!vm:other-pointer-lowtag)
372 (inst cmpwi :cr1 temp 0)
374 ;; positive implies (unsigned-byte 32).
376 (inst b? :cr1 (if not-p :lt :ge) target)
378 (emit-label not-target)))))
380 (define-vop (check-unsigned-byte-32 check-type)
383 (generate-error-code vop object-not-unsigned-byte-32-error value))
386 (single-word (gen-label)))
388 (inst andi. temp value #x3)
389 (inst cmpwi :cr1 value 0)
392 ;; If not, is it an other pointer?
393 (test-type value temp nope t sb!vm:other-pointer-lowtag)
394 ;; Get the number of digits.
395 (loadw temp value 0 sb!vm:other-pointer-lowtag)
397 (inst cmpwi temp (+ (ash 1 sb!vm:n-widetag-bits) sb!vm:bignum-widetag))
398 (inst beq single-word)
399 ;; If it's other than two, we can't be an (unsigned-byte 32)
400 (inst cmpwi temp (+ (ash 2 sb!vm:n-widetag-bits) sb!vm:bignum-widetag))
402 ;; Get the second digit.
403 (loadw temp value (1+ sb!vm:bignum-digits-offset) sb!vm:other-pointer-lowtag)
404 ;; All zeros, its an (unsigned-byte 32).
407 ;; Otherwise, it isn't.
410 (emit-label single-word)
411 ;; Get the single digit.
412 (loadw temp value sb!vm:bignum-digits-offset sb!vm:other-pointer-lowtag)
413 ;; positive implies (unsigned-byte 32).
414 (inst cmpwi :cr1 temp 0)
420 (move result value))))
425 ;;;; List/symbol types:
427 ;;; symbolp (or symbol (eq nil))
428 ;;; consp (and list (not (eq nil)))
430 (define-vop (symbolp type-predicate)
433 (let* ((drop-thru (gen-label))
434 (is-symbol-label (if not-p drop-thru target)))
435 (inst cmpw value null-tn)
436 (inst beq is-symbol-label)
437 (test-type value temp target not-p sb!vm:symbol-header-widetag)
438 (emit-label drop-thru))))
440 (define-vop (check-symbol check-type)
442 (let ((drop-thru (gen-label))
443 (error (generate-error-code vop object-not-symbol-error value)))
444 (inst cmpw value null-tn)
446 (test-type value temp error t sb!vm:symbol-header-widetag)
447 (emit-label drop-thru)
448 (move result value))))
450 (define-vop (consp type-predicate)
453 (let* ((drop-thru (gen-label))
454 (is-not-cons-label (if not-p target drop-thru)))
455 (inst cmpw value null-tn)
456 (inst beq is-not-cons-label)
457 (test-type value temp target not-p sb!vm:list-pointer-lowtag)
458 (emit-label drop-thru))))
460 (define-vop (check-cons check-type)
462 (let ((error (generate-error-code vop object-not-cons-error value)))
463 (inst cmpw value null-tn)
465 (test-type value temp error t sb!vm:list-pointer-lowtag)
466 (move result value))))