1 ;;;; type testing and checking VOPs for the Alpha VM
3 ;;;; This software is part of the SBCL system. See the README file for
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.
14 (defun %test-fixnum (value target not-p &key temp)
16 (inst and value fixnum-tag-mask temp)
18 (inst bne temp target)
19 (inst beq temp target))))
21 (defun %test-fixnum-and-headers (value target not-p headers &key temp)
22 (let ((drop-through (gen-label)))
24 (inst and value fixnum-tag-mask temp)
25 (inst beq temp (if not-p drop-through target)))
26 (%test-headers value target not-p nil headers
27 :drop-through drop-through :temp temp)))
29 (defun %test-immediate (value target not-p immediate &key temp)
31 (inst and value 255 temp)
32 (inst xor temp immediate temp)
34 (inst bne temp target)
35 (inst beq temp target))))
37 (defun %test-lowtag (value target not-p lowtag &key temp)
39 (inst and value lowtag-mask temp)
40 (inst xor temp lowtag temp)
42 (inst bne temp target)
43 (inst beq temp target))))
45 (defun %test-headers (value target not-p function-p headers
46 &key (drop-through (gen-label)) temp)
47 (let ((lowtag (if function-p fun-pointer-lowtag other-pointer-lowtag)))
49 (when-true when-false)
50 ;; WHEN-TRUE and WHEN-FALSE are the labels to branch to when
51 ;; we know it's true and when we know it's false respectively.
53 (values drop-through target)
54 (values target drop-through))
56 (%test-lowtag value when-false t lowtag :temp temp)
57 (load-type temp value (- lowtag))
59 (do ((remaining headers (cdr remaining)))
61 (let ((header (car remaining))
62 (last (null (cdr remaining))))
65 (inst subq temp (- header delta) temp)
69 (inst bne temp target)
70 (inst beq temp target))
71 (inst beq temp when-true)))
73 (let ((start (car header))
75 (unless (= start bignum-widetag)
76 (inst subq temp (- start delta) temp)
78 (inst blt temp when-false))
79 (inst subq temp (- end delta) temp)
83 (inst bgt temp target)
84 (inst ble temp target))
85 (inst ble temp when-true))))))))
86 (emit-label drop-through)))))
88 ;;;; Type checking and testing:
90 (define-vop (check-type)
91 (:args (value :target result :scs (any-reg descriptor-reg)))
92 (:results (result :scs (any-reg descriptor-reg)))
93 (:temporary (:scs (non-descriptor-reg) :to (:result 0)) temp)
95 (:save-p :compute-only))
97 (define-vop (type-predicate)
98 (:args (value :scs (any-reg descriptor-reg)))
99 (:temporary (:scs (non-descriptor-reg)) temp)
102 (:policy :fast-safe))
104 (defun cost-to-test-types (type-codes)
105 (+ (* 2 (length type-codes))
106 (if (> (apply #'max type-codes) lowtag-limit) 7 2)))
108 (defmacro !define-type-vops (pred-name check-name ptype error-code
110 &key &allow-other-keys)
111 (let ((cost (cost-to-test-types (mapcar #'eval type-codes))))
114 `((define-vop (,pred-name type-predicate)
115 (:translate ,pred-name)
117 (test-type value target not-p (,@type-codes) :temp temp)))))
119 `((define-vop (,check-name check-type)
122 (generate-error-code vop ,error-code value)))
123 (test-type value err-lab t (,@type-codes) :temp temp)
124 (move value result))))))
126 `((primitive-type-vop ,check-name (:check) ,ptype))))))
128 ;;;; Other integer ranges.
130 ;;; A (signed-byte 32) can be represented with either fixnum or a bignum with
131 ;;; exactly one digit.
133 (defun signed-byte-32-test (value temp temp1 not-p target not-target)
137 (values not-target target)
138 (values target not-target))
140 (inst and value fixnum-tag-mask temp)
142 (inst and value lowtag-mask temp)
143 (inst xor temp other-pointer-lowtag temp)
145 (loadw temp value 0 other-pointer-lowtag)
146 (inst li (+ (ash 1 n-widetag-bits) bignum-widetag) temp1)
147 (inst xor temp temp1 temp)
149 (inst bne temp target)
150 (inst beq temp target))))
153 (define-vop (signed-byte-32-p type-predicate)
154 (:translate signed-byte-32-p)
155 (:temporary (:scs (non-descriptor-reg)) temp1)
157 (signed-byte-32-test value temp temp1 not-p target not-target)
160 (define-vop (check-signed-byte-32 check-type)
161 (:temporary (:scs (non-descriptor-reg)) temp1)
163 (let ((loose (generate-error-code vop object-not-signed-byte-32-error
165 (signed-byte-32-test value temp temp1 t loose okay))
167 (move value result)))
169 ;;; An (unsigned-byte 32) can be represented with either a positive fixnum, a
170 ;;; bignum with exactly one positive digit, or a bignum with exactly two digits
171 ;;; and the second digit all zeros.
173 (defun unsigned-byte-32-test (value temp temp1 not-p target not-target)
174 (multiple-value-bind (yep nope)
176 (values not-target target)
177 (values target not-target))
180 (inst and value fixnum-tag-mask temp1)
181 (inst move value temp)
182 (inst beq temp1 fixnum)
184 ;; If not, is it an other pointer?
185 (inst and value lowtag-mask temp)
186 (inst xor temp other-pointer-lowtag temp)
189 (loadw temp value 0 other-pointer-lowtag)
191 (inst li (+ (ash 1 n-widetag-bits) bignum-widetag) temp1)
192 (inst xor temp temp1 temp)
193 (inst beq temp single-word)
194 ;; If it's other than two, we can't be an (unsigned-byte 32)
195 (inst li (logxor (+ (ash 1 n-widetag-bits) bignum-widetag)
196 (+ (ash 2 n-widetag-bits) bignum-widetag))
198 (inst xor temp temp1 temp)
200 ;; Get the second digit.
201 (loadw temp value (1+ bignum-digits-offset) other-pointer-lowtag)
202 ;; All zeros, its an (unsigned-byte 32).
204 (inst br zero-tn nope)
207 ;; Get the single digit.
208 (loadw temp value bignum-digits-offset other-pointer-lowtag)
210 ;; positive implies (unsigned-byte 32).
213 (inst blt temp target)
214 (inst bge temp target))))
217 (define-vop (unsigned-byte-32-p type-predicate)
218 (:translate unsigned-byte-32-p)
219 (:temporary (:scs (non-descriptor-reg)) temp1)
221 (unsigned-byte-32-test value temp temp1 not-p target not-target)
224 (define-vop (check-unsigned-byte-32 check-type)
225 (:temporary (:scs (non-descriptor-reg)) temp1)
227 (let ((loose (generate-error-code vop object-not-unsigned-byte-32-error
229 (unsigned-byte-32-test value temp temp1 t loose okay))
231 (move value result)))
235 ;;;; List/symbol types:
237 ;;; symbolp (or symbol (eq nil))
238 ;;; consp (and list (not (eq nil)))
240 (define-vop (symbolp type-predicate)
242 (:temporary (:scs (non-descriptor-reg)) temp)
244 (inst cmpeq value null-tn temp)
245 (inst bne temp (if not-p drop-thru target))
246 (test-type value target not-p (symbol-header-widetag) :temp temp)
249 (define-vop (check-symbol check-type)
250 (:temporary (:scs (non-descriptor-reg)) temp)
252 (inst cmpeq value null-tn temp)
253 (inst bne temp drop-thru)
254 (let ((error (generate-error-code vop object-not-symbol-error value)))
255 (test-type value error t (symbol-header-widetag) :temp temp))
257 (move value result)))
259 (define-vop (consp type-predicate)
261 (:temporary (:scs (non-descriptor-reg)) temp)
263 (inst cmpeq value null-tn temp)
264 (inst bne temp (if not-p target drop-thru))
265 (test-type value target not-p (list-pointer-lowtag) :temp temp)
268 (define-vop (check-cons check-type)
269 (:temporary (:scs (non-descriptor-reg)) temp)
271 (let ((error (generate-error-code vop object-not-cons-error value)))
272 (inst cmpeq value null-tn temp)
273 (inst bne temp error)
274 (test-type value error t (list-pointer-lowtag) :temp temp))
275 (move value result)))