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 3 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 3 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-lowtag-and-headers (value target not-p lowtag
46 function-p headers &key temp)
47 (let ((drop-through (gen-label)))
48 (%test-lowtag value (if not-p drop-through target) nil lowtag :temp temp)
49 (%test-headers value target not-p function-p headers
50 :drop-through drop-through :temp temp)))
52 (defun %test-headers (value target not-p function-p headers
53 &key (drop-through (gen-label)) temp)
54 (let ((lowtag (if function-p fun-pointer-lowtag other-pointer-lowtag)))
56 (when-true when-false)
57 ;; WHEN-TRUE and WHEN-FALSE are the labels to branch to when
58 ;; we know it's true and when we know it's false respectively.
60 (values drop-through target)
61 (values target drop-through))
63 (%test-lowtag value when-false t lowtag :temp temp)
64 (load-type temp value (- lowtag))
66 (do ((remaining headers (cdr remaining)))
68 (let ((header (car remaining))
69 (last (null (cdr remaining))))
72 (inst subq temp (- header delta) temp)
76 (inst bne temp target)
77 (inst beq temp target))
78 (inst beq temp when-true)))
80 (let ((start (car header))
82 (unless (= start bignum-widetag)
83 (inst subq temp (- start delta) temp)
85 (inst blt temp when-false))
86 (inst subq temp (- end delta) temp)
90 (inst bgt temp target)
91 (inst ble temp target))
92 (inst ble temp when-true))))))))
93 (emit-label drop-through)))))
95 ;;;; Type checking and testing:
97 (define-vop (check-type)
98 (:args (value :target result :scs (any-reg descriptor-reg)))
99 (:results (result :scs (any-reg descriptor-reg)))
100 (:temporary (:scs (non-descriptor-reg) :to (:result 0)) temp)
102 (:save-p :compute-only))
104 (define-vop (type-predicate)
105 (:args (value :scs (any-reg descriptor-reg)))
106 (:temporary (:scs (non-descriptor-reg)) temp)
109 (:policy :fast-safe))
111 (defun cost-to-test-types (type-codes)
112 (+ (* 2 (length type-codes))
113 (if (> (apply #'max type-codes) lowtag-limit) 7 2)))
115 (defmacro !define-type-vops (pred-name check-name ptype error-code
117 &key &allow-other-keys)
118 (let ((cost (cost-to-test-types (mapcar #'eval type-codes))))
121 `((define-vop (,pred-name type-predicate)
122 (:translate ,pred-name)
124 (test-type value target not-p (,@type-codes) :temp temp)))))
126 `((define-vop (,check-name check-type)
129 (generate-error-code vop ,error-code value)))
130 (test-type value err-lab t (,@type-codes) :temp temp)
131 (move value result))))))
133 `((primitive-type-vop ,check-name (:check) ,ptype))))))
135 ;;;; Other integer ranges.
137 ;;; A (signed-byte 32) can be represented with either fixnum or a bignum with
138 ;;; exactly one digit.
140 (defun signed-byte-32-test (value temp temp1 not-p target not-target)
144 (values not-target target)
145 (values target not-target))
147 (inst and value 3 temp)
149 (inst and value lowtag-mask temp)
150 (inst xor temp other-pointer-lowtag temp)
152 (loadw temp value 0 other-pointer-lowtag)
153 (inst li (+ (ash 1 n-widetag-bits) bignum-widetag) temp1)
154 (inst xor temp temp1 temp)
156 (inst bne temp target)
157 (inst beq temp target))))
160 (define-vop (signed-byte-32-p type-predicate)
161 (:translate signed-byte-32-p)
162 (:temporary (:scs (non-descriptor-reg)) temp1)
164 (signed-byte-32-test value temp temp1 not-p target not-target)
167 (define-vop (check-signed-byte-32 check-type)
168 (:temporary (:scs (non-descriptor-reg)) temp1)
170 (let ((loose (generate-error-code vop object-not-signed-byte-32-error
172 (signed-byte-32-test value temp temp1 t loose okay))
174 (move value result)))
176 ;;; An (unsigned-byte 32) can be represented with either a positive fixnum, a
177 ;;; bignum with exactly one positive digit, or a bignum with exactly two digits
178 ;;; and the second digit all zeros.
180 (defun unsigned-byte-32-test (value temp temp1 not-p target not-target)
181 (multiple-value-bind (yep nope)
183 (values not-target target)
184 (values target not-target))
187 (inst and value 3 temp1)
188 (inst move value temp)
189 (inst beq temp1 fixnum)
191 ;; If not, is it an other pointer?
192 (inst and value lowtag-mask temp)
193 (inst xor temp other-pointer-lowtag temp)
196 (loadw temp value 0 other-pointer-lowtag)
198 (inst li (+ (ash 1 n-widetag-bits) bignum-widetag) temp1)
199 (inst xor temp temp1 temp)
200 (inst beq temp single-word)
201 ;; If it's other than two, we can't be an (unsigned-byte 32)
202 (inst li (logxor (+ (ash 1 n-widetag-bits) bignum-widetag)
203 (+ (ash 2 n-widetag-bits) bignum-widetag))
205 (inst xor temp temp1 temp)
207 ;; Get the second digit.
208 (loadw temp value (1+ bignum-digits-offset) other-pointer-lowtag)
209 ;; All zeros, its an (unsigned-byte 32).
211 (inst br zero-tn nope)
214 ;; Get the single digit.
215 (loadw temp value bignum-digits-offset other-pointer-lowtag)
217 ;; positive implies (unsigned-byte 32).
220 (inst blt temp target)
221 (inst bge temp target))))
224 (define-vop (unsigned-byte-32-p type-predicate)
225 (:translate unsigned-byte-32-p)
226 (:temporary (:scs (non-descriptor-reg)) temp1)
228 (unsigned-byte-32-test value temp temp1 not-p target not-target)
231 (define-vop (check-unsigned-byte-32 check-type)
232 (:temporary (:scs (non-descriptor-reg)) temp1)
234 (let ((loose (generate-error-code vop object-not-unsigned-byte-32-error
236 (unsigned-byte-32-test value temp temp1 t loose okay))
238 (move value result)))
242 ;;;; List/symbol types:
244 ;;; symbolp (or symbol (eq nil))
245 ;;; consp (and list (not (eq nil)))
247 (define-vop (symbolp type-predicate)
249 (:temporary (:scs (non-descriptor-reg)) temp)
251 (inst cmpeq value null-tn temp)
252 (inst bne temp (if not-p drop-thru target))
253 (test-type value target not-p (symbol-header-widetag) :temp temp)
256 (define-vop (check-symbol check-type)
257 (:temporary (:scs (non-descriptor-reg)) temp)
259 (inst cmpeq value null-tn temp)
260 (inst bne temp drop-thru)
261 (let ((error (generate-error-code vop object-not-symbol-error value)))
262 (test-type value error t (symbol-header-widetag) :temp temp))
264 (move value result)))
266 (define-vop (consp type-predicate)
268 (:temporary (:scs (non-descriptor-reg)) temp)
270 (inst cmpeq value null-tn temp)
271 (inst bne temp (if not-p target drop-thru))
272 (test-type value target not-p (list-pointer-lowtag) :temp temp)
275 (define-vop (check-cons check-type)
276 (:temporary (:scs (non-descriptor-reg)) temp)
278 (let ((error (generate-error-code vop object-not-cons-error value)))
279 (inst cmpeq value null-tn temp)
280 (inst bne temp error)
281 (test-type value error t (list-pointer-lowtag) :temp temp))
282 (move value result)))