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-headers (value target not-p function-p headers
53 &key temp (drop-through (gen-label)))
54 (let ((lowtag (if function-p fun-pointer-lowtag other-pointer-lowtag)))
55 (multiple-value-bind (when-true when-false)
57 (values drop-through target)
58 (values target drop-through))
60 (%test-lowtag value when-false t lowtag :temp temp)
61 (load-type temp value (- lowtag))
62 (do ((remaining headers (cdr remaining)))
64 (let ((header (car remaining))
65 (last (null (cdr remaining))))
68 (inst cmp temp header)
70 ;; FIXME: Some SPARC-V9 magic might not go amiss
71 ;; here, too, if I can figure out what it should
73 (inst b (if not-p :ne :eq) target)
74 (inst b :eq when-true)))
76 (let ((start (car header))
78 ;; FIXME: BIGNUM-WIDETAG here actually means (MIN
80 (unless (= start bignum-widetag)
82 (inst b :lt when-false))
83 ;; FIXME: conceivably, it might be worth having a
84 ;; (MAX <widetags>) here too.
87 (inst b (if not-p :gt :le) target)
88 (inst b :le when-true)))))))
90 (emit-label drop-through)))))
92 ;;;; Simple type checking and testing:
94 ;;; These types are represented by a single type code, so are easily
95 ;;; open-coded as a mask and compare.
96 (define-vop (check-type)
97 (:args (value :target result :scs (any-reg descriptor-reg)))
98 (:results (result :scs (any-reg descriptor-reg)))
99 (:temporary (:scs (non-descriptor-reg)) temp)
101 (:save-p :compute-only))
103 (define-vop (type-predicate)
104 (:args (value :scs (any-reg descriptor-reg)))
108 (:temporary (:scs (non-descriptor-reg)) temp))
110 (defun cost-to-test-types (type-codes)
111 (+ (* 2 (length type-codes))
112 (if (> (apply #'max type-codes) lowtag-limit) 7 2)))
114 (defmacro !define-type-vops (pred-name check-name ptype error-code
116 &key &allow-other-keys)
117 (let ((cost (cost-to-test-types (mapcar #'eval type-codes))))
120 `((define-vop (,pred-name type-predicate)
121 (:translate ,pred-name)
123 (test-type value target not-p (,@type-codes)
126 `((define-vop (,check-name check-type)
129 (generate-error-code vop ,error-code value)))
130 (test-type value err-lab t (,@type-codes)
132 (move result value))))))
134 `((primitive-type-vop ,check-name (:check) ,ptype))))))
137 ;;;; Other integer ranges.
139 ;; A (signed-byte 32) can be represented with either fixnum or a
140 ;; bignum with exactly one digit.
142 (define-vop (signed-byte-32-p type-predicate)
143 (:translate signed-byte-32-p)
145 (let ((not-target (gen-label)))
149 (values not-target target)
150 (values target not-target))
151 (inst andcc zero-tn value #x3)
153 (test-type value nope t (other-pointer-lowtag) :temp temp)
154 (loadw temp value 0 other-pointer-lowtag)
155 (inst cmp temp (+ (ash 1 n-widetag-bits)
157 (inst b (if not-p :ne :eq) target)
159 (emit-label not-target)))))
161 (define-vop (check-signed-byte-32 check-type)
163 (let ((nope (generate-error-code vop object-not-signed-byte-32-error value))
165 (inst andcc temp value #x3)
167 (test-type value nope t (other-pointer-lowtag) :temp temp)
168 (loadw temp value 0 other-pointer-lowtag)
169 (inst cmp temp (+ (ash 1 n-widetag-bits) bignum-widetag))
173 (move result value))))
176 ;; An (unsigned-byte 32) can be represented with either a
177 ;; positive fixnum, a bignum with exactly one positive digit, or
178 ;; a bignum with exactly two digits and the second digit all
181 (define-vop (unsigned-byte-32-p type-predicate)
182 (:translate unsigned-byte-32-p)
184 (let ((not-target (gen-label))
185 (single-word (gen-label))
186 (fixnum (gen-label)))
190 (values not-target target)
191 (values target not-target))
193 (inst andcc temp value #x3)
197 ;; If not, is it an other pointer?
198 (test-type value nope t (other-pointer-lowtag) :temp temp)
200 (loadw temp value 0 other-pointer-lowtag)
202 (inst cmp temp (+ (ash 1 n-widetag-bits) bignum-widetag))
203 (inst b :eq single-word)
204 ;; If it's other than two, we can't be an
205 ;; (unsigned-byte 32)
206 (inst cmp temp (+ (ash 2 n-widetag-bits) bignum-widetag))
208 ;; Get the second digit.
209 (loadw temp value (1+ bignum-digits-offset) other-pointer-lowtag)
210 ;; All zeros, its an (unsigned-byte 32).
214 ;; Otherwise, it isn't.
218 (emit-label single-word)
219 ;; Get the single digit.
220 (loadw temp value bignum-digits-offset other-pointer-lowtag)
223 ;; positive implies (unsigned-byte 32).
225 (inst b (if not-p :lt :ge) target)
228 (emit-label not-target)))))
230 (define-vop (check-unsigned-byte-32 check-type)
233 (generate-error-code vop object-not-unsigned-byte-32-error value))
236 (single-word (gen-label)))
238 (inst andcc temp value #x3)
242 ;; If not, is it an other pointer?
243 (test-type value nope t (other-pointer-lowtag) :temp temp)
244 ;; Get the number of digits.
245 (loadw temp value 0 other-pointer-lowtag)
247 (inst cmp temp (+ (ash 1 n-widetag-bits) bignum-widetag))
248 (inst b :eq single-word)
249 ;; If it's other than two, we can't be an (unsigned-byte 32)
250 (inst cmp temp (+ (ash 2 n-widetag-bits) bignum-widetag))
252 ;; Get the second digit.
253 (loadw temp value (1+ bignum-digits-offset) other-pointer-lowtag)
254 ;; All zeros, its an (unsigned-byte 32).
257 ;; Otherwise, it isn't.
261 (emit-label single-word)
262 ;; Get the single digit.
263 (loadw temp value bignum-digits-offset other-pointer-lowtag)
264 ;; positive implies (unsigned-byte 32).
272 (move result value))))
276 ;;;; List/symbol types:
278 ;; symbolp (or symbol (eq nil))
279 ;; consp (and list (not (eq nil)))
281 (define-vop (symbolp type-predicate)
284 (let* ((drop-thru (gen-label))
285 (is-symbol-label (if not-p drop-thru target)))
286 (inst cmp value null-tn)
287 (inst b :eq is-symbol-label)
288 (test-type value target not-p (symbol-header-widetag) :temp temp)
289 (emit-label drop-thru))))
291 (define-vop (check-symbol check-type)
293 (let ((drop-thru (gen-label))
294 (error (generate-error-code vop object-not-symbol-error value)))
295 (inst cmp value null-tn)
296 (inst b :eq drop-thru)
297 (test-type value error t (symbol-header-widetag) :temp temp)
298 (emit-label drop-thru)
299 (move result value))))
301 (define-vop (consp type-predicate)
304 (let* ((drop-thru (gen-label))
305 (is-not-cons-label (if not-p target drop-thru)))
306 (inst cmp value null-tn)
307 (inst b :eq is-not-cons-label)
308 (test-type value target not-p (list-pointer-lowtag) :temp temp)
309 (emit-label drop-thru))))
311 (define-vop (check-cons check-type)
313 (let ((error (generate-error-code vop object-not-cons-error value)))
314 (inst cmp value null-tn)
316 (test-type value error t (list-pointer-lowtag) :temp temp)
317 (move result value))))