1 ;;;; type testing and checking VOPs for the Sparc 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.
15 (defun %test-fixnum (value target not-p &key temp)
16 (declare (ignore temp))
18 (inst andcc zero-tn value fixnum-tag-mask)
19 (if (member :sparc-v9 *backend-subfeatures*)
20 (inst b (if not-p :ne :eq) target (if not-p :pn :pt))
21 (inst b (if not-p :ne :eq) target))
24 (defun %test-fixnum-and-headers (value target not-p headers
26 (let ((drop-through (gen-label)))
28 (inst andcc zero-tn value fixnum-tag-mask)
29 (inst b :eq (if not-p drop-through target)))
30 (%test-headers value target not-p nil headers
31 :drop-through drop-through
34 (defun %test-immediate (value target not-p immediate &key temp)
36 (inst and temp value widetag-mask)
37 (inst cmp temp immediate)
38 ;; FIXME: include SPARC-V9 magic
39 (inst b (if not-p :ne :eq) target)
42 (defun %test-lowtag (value target not-p lowtag
45 (inst and temp value lowtag-mask)
46 (inst cmp temp lowtag)
47 ;; FIXME: include SPARC-V9 magic
48 (inst b (if not-p :ne :eq) target)
52 (defun %test-lowtag-and-headers (value target not-p lowtag function-p headers
54 (let ((drop-through (gen-label)))
55 (%test-lowtag value (if not-p drop-through target) not-p lowtag
56 :temp temp :skip-nop t)
57 (%test-headers value target not-p function-p headers
58 :temp temp :drop-through drop-through)))
60 (defun %test-headers (value target not-p function-p headers
61 &key temp (drop-through (gen-label)))
62 (let ((lowtag (if function-p fun-pointer-lowtag other-pointer-lowtag)))
63 (multiple-value-bind (when-true when-false)
65 (values drop-through target)
66 (values target drop-through))
68 (%test-lowtag value when-false t lowtag :temp temp)
69 (load-type temp value (- lowtag))
70 (do ((remaining headers (cdr remaining)))
72 (let ((header (car remaining))
73 (last (null (cdr remaining))))
76 (inst cmp temp header)
78 ;; FIXME: Some SPARC-V9 magic might not go amiss
79 ;; here, too, if I can figure out what it should
81 (inst b (if not-p :ne :eq) target)
82 (inst b :eq when-true)))
84 (let ((start (car header))
86 ;; FIXME: BIGNUM-WIDETAG here actually means (MIN
88 (unless (= start bignum-widetag)
90 (inst b :lt when-false))
91 ;; FIXME: conceivably, it might be worth having a
92 ;; (MAX <widetags>) here too.
95 (inst b (if not-p :gt :le) target)
96 (inst b :le when-true)))))))
98 (emit-label drop-through)))))
100 ;;;; Simple type checking and testing:
102 ;;; These types are represented by a single type code, so are easily
103 ;;; open-coded as a mask and compare.
104 (define-vop (check-type)
105 (:args (value :target result :scs (any-reg descriptor-reg)))
106 (:results (result :scs (any-reg descriptor-reg)))
107 (:temporary (:scs (non-descriptor-reg)) temp)
109 (:save-p :compute-only))
111 (define-vop (type-predicate)
112 (:args (value :scs (any-reg descriptor-reg)))
116 (:temporary (:scs (non-descriptor-reg)) temp))
118 (defun cost-to-test-types (type-codes)
119 (+ (* 2 (length type-codes))
120 (if (> (apply #'max type-codes) lowtag-limit) 7 2)))
122 (defmacro !define-type-vops (pred-name check-name ptype error-code
124 &key &allow-other-keys)
125 (let ((cost (cost-to-test-types (mapcar #'eval type-codes))))
128 `((define-vop (,pred-name type-predicate)
129 (:translate ,pred-name)
131 (test-type value target not-p (,@type-codes)
134 `((define-vop (,check-name check-type)
137 (generate-error-code vop ,error-code value)))
138 (test-type value err-lab t (,@type-codes)
140 (move result value))))))
142 `((primitive-type-vop ,check-name (:check) ,ptype))))))
145 ;;;; Other integer ranges.
147 ;; A (signed-byte 32) can be represented with either fixnum or a
148 ;; bignum with exactly one digit.
150 (define-vop (signed-byte-32-p type-predicate)
151 (:translate signed-byte-32-p)
153 (let ((not-target (gen-label)))
157 (values not-target target)
158 (values target not-target))
159 (inst andcc zero-tn value #x3)
161 (test-type value nope t (other-pointer-lowtag) :temp temp)
162 (loadw temp value 0 other-pointer-lowtag)
163 (inst cmp temp (+ (ash 1 n-widetag-bits)
165 (inst b (if not-p :ne :eq) target)
167 (emit-label not-target)))))
169 (define-vop (check-signed-byte-32 check-type)
171 (let ((nope (generate-error-code vop object-not-signed-byte-32-error value))
173 (inst andcc temp value #x3)
175 (test-type value nope t (other-pointer-lowtag) :temp temp)
176 (loadw temp value 0 other-pointer-lowtag)
177 (inst cmp temp (+ (ash 1 n-widetag-bits) bignum-widetag))
181 (move result value))))
184 ;; An (unsigned-byte 32) can be represented with either a
185 ;; positive fixnum, a bignum with exactly one positive digit, or
186 ;; a bignum with exactly two digits and the second digit all
189 (define-vop (unsigned-byte-32-p type-predicate)
190 (:translate unsigned-byte-32-p)
192 (let ((not-target (gen-label))
193 (single-word (gen-label))
194 (fixnum (gen-label)))
198 (values not-target target)
199 (values target not-target))
201 (inst andcc temp value #x3)
205 ;; If not, is it an other pointer?
206 (test-type value nope t (other-pointer-lowtag) :temp temp)
208 (loadw temp value 0 other-pointer-lowtag)
210 (inst cmp temp (+ (ash 1 n-widetag-bits) bignum-widetag))
211 (inst b :eq single-word)
212 ;; If it's other than two, we can't be an
213 ;; (unsigned-byte 32)
214 (inst cmp temp (+ (ash 2 n-widetag-bits) bignum-widetag))
216 ;; Get the second digit.
217 (loadw temp value (1+ bignum-digits-offset) other-pointer-lowtag)
218 ;; All zeros, its an (unsigned-byte 32).
222 ;; Otherwise, it isn't.
226 (emit-label single-word)
227 ;; Get the single digit.
228 (loadw temp value bignum-digits-offset other-pointer-lowtag)
231 ;; positive implies (unsigned-byte 32).
233 (inst b (if not-p :lt :ge) target)
236 (emit-label not-target)))))
238 (define-vop (check-unsigned-byte-32 check-type)
241 (generate-error-code vop object-not-unsigned-byte-32-error value))
244 (single-word (gen-label)))
246 (inst andcc temp value #x3)
250 ;; If not, is it an other pointer?
251 (test-type value nope t (other-pointer-lowtag) :temp temp)
252 ;; Get the number of digits.
253 (loadw temp value 0 other-pointer-lowtag)
255 (inst cmp temp (+ (ash 1 n-widetag-bits) bignum-widetag))
256 (inst b :eq single-word)
257 ;; If it's other than two, we can't be an (unsigned-byte 32)
258 (inst cmp temp (+ (ash 2 n-widetag-bits) bignum-widetag))
260 ;; Get the second digit.
261 (loadw temp value (1+ bignum-digits-offset) other-pointer-lowtag)
262 ;; All zeros, its an (unsigned-byte 32).
265 ;; Otherwise, it isn't.
269 (emit-label single-word)
270 ;; Get the single digit.
271 (loadw temp value bignum-digits-offset other-pointer-lowtag)
272 ;; positive implies (unsigned-byte 32).
280 (move result value))))
284 ;;;; List/symbol types:
286 ;; symbolp (or symbol (eq nil))
287 ;; consp (and list (not (eq nil)))
289 (define-vop (symbolp type-predicate)
292 (let* ((drop-thru (gen-label))
293 (is-symbol-label (if not-p drop-thru target)))
294 (inst cmp value null-tn)
295 (inst b :eq is-symbol-label)
296 (test-type value target not-p (symbol-header-widetag) :temp temp)
297 (emit-label drop-thru))))
299 (define-vop (check-symbol check-type)
301 (let ((drop-thru (gen-label))
302 (error (generate-error-code vop object-not-symbol-error value)))
303 (inst cmp value null-tn)
304 (inst b :eq drop-thru)
305 (test-type value error t (symbol-header-widetag) :temp temp)
306 (emit-label drop-thru)
307 (move result value))))
309 (define-vop (consp type-predicate)
312 (let* ((drop-thru (gen-label))
313 (is-not-cons-label (if not-p target drop-thru)))
314 (inst cmp value null-tn)
315 (inst b :eq is-not-cons-label)
316 (test-type value target not-p (list-pointer-lowtag) :temp temp)
317 (emit-label drop-thru))))
319 (define-vop (check-cons check-type)
321 (let ((error (generate-error-code vop object-not-cons-error value)))
322 (inst cmp value null-tn)
324 (test-type value error t (list-pointer-lowtag) :temp temp)
325 (move result value))))