1 ;;;; type testing and checking VOPs for the PPC 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 andi. temp value fixnum-tag-mask)
17 (inst b? (if not-p :ne :eq) target)))
19 (defun %test-fixnum-and-headers (value target not-p headers &key temp)
20 (let ((drop-through (gen-label)))
22 (inst andi. temp value fixnum-tag-mask)
23 (inst beq (if not-p drop-through target)))
24 (%test-headers value target not-p nil headers
25 :drop-through drop-through :temp temp)))
27 (defun %test-immediate (value target not-p immediate &key temp)
29 (inst andi. temp value widetag-mask)
30 (inst cmpwi temp immediate)
31 (inst b? (if not-p :ne :eq) target)))
33 (defun %test-lowtag (value target not-p lowtag &key temp)
35 (inst andi. temp value lowtag-mask)
36 (inst cmpwi temp lowtag)
37 (inst b? (if not-p :ne :eq) target)))
39 (defun %test-headers (value target not-p function-p headers
40 &key temp (drop-through (gen-label)))
41 (let ((lowtag (if function-p fun-pointer-lowtag other-pointer-lowtag)))
42 (multiple-value-bind (when-true when-false)
44 (values drop-through target)
45 (values target drop-through))
47 (%test-lowtag value when-false t lowtag :temp temp)
48 (load-type temp value (- lowtag))
49 (do ((remaining headers (cdr remaining)))
51 (let ((header (car remaining))
52 (last (null (cdr remaining))))
56 ((and (not last) (null (cddr remaining))
57 (atom (cadr remaining))
58 (= (logcount (logxor header (cadr remaining))) 1))
59 (inst andi. temp temp (ldb (byte 8 0) (logeqv header (cadr remaining))))
60 (inst cmpwi temp (ldb (byte 8 0) (logand header (cadr remaining))))
61 (inst b? (if not-p :ne :eq) target)
64 (inst cmpwi temp header)
66 (inst b? (if not-p :ne :eq) target)
67 (inst beq when-true)))))
69 (let ((start (car header))
72 ((and last (not (= start bignum-widetag))
74 (= (logcount (logxor start end)) 1))
75 (inst andi. temp temp (ldb (byte 8 0) (logeqv start end)))
76 (inst cmpwi temp (ldb (byte 8 0) (logand start end)))
77 (inst b? (if not-p :ne :eq) target))
78 ((and (not last) (null (cddr remaining))
79 (= (+ start 4) end) (= (logcount (logxor start end)) 1)
80 (listp (cadr remaining))
81 (= (+ (caadr remaining) 4) (cdadr remaining))
82 (= (logcount (logxor (caadr remaining) (cdadr remaining))) 1)
83 (= (logcount (logxor (caadr remaining) start)) 1))
84 (inst andi. temp temp (ldb (byte 8 0) (logeqv start (cdadr remaining))))
85 (inst cmpwi temp (ldb (byte 8 0) (logand start (cdadr remaining))))
86 (inst b? (if not-p :ne :eq) target)
89 (unless (= start bignum-widetag)
90 (inst cmpwi temp start)
91 (if (= end complex-array-widetag)
94 (inst b? (if not-p :lt :ge) target))
95 (inst blt when-false)))
96 (unless (= end complex-array-widetag)
99 (inst b? (if not-p :gt :le) target)
100 (inst ble when-true))))))))))
101 (emit-label drop-through)))))
103 ;;; Simple type checking and testing:
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 ;; KLUDGE: ideally, the compiler could
125 ;; derive that it can use the sneaky trap
126 ;; twice mechanism itself. However, one
127 ;; thing at a time...
128 &key mask &allow-other-keys)
129 (let ((cost (cost-to-test-types (mapcar #'eval type-codes))))
132 `((define-vop (,pred-name type-predicate)
133 (:translate ,pred-name)
135 (test-type value target not-p (,@type-codes) :temp temp)))))
137 `((define-vop (,check-name check-type)
140 `((inst andi. temp value ,mask)
141 (inst twi 0 value (error-number-or-lose ',error-code))
142 (inst twi :ne temp ,@(ecase mask
143 ((fixnum-tag-mask) `(0))
144 ((lowtag-mask) type-codes)))
147 (generate-error-code vop ',error-code value)))
148 (test-type value err-lab t (,@type-codes) :temp temp)
149 (move result value))))))))
151 `((primitive-type-vop ,check-name (:check) ,ptype))))))
153 ;;;; Other integer ranges.
155 ;;; A (signed-byte 32) can be represented with either fixnum or a bignum with
156 ;;; exactly one digit.
158 (define-vop (signed-byte-32-p type-predicate)
159 (:translate signed-byte-32-p)
161 (let ((not-target (gen-label)))
165 (values not-target target)
166 (values target not-target))
167 (inst andi. temp value fixnum-tag-mask)
169 (test-type value nope t (other-pointer-lowtag) :temp temp)
170 (loadw temp value 0 other-pointer-lowtag)
171 (inst cmpwi temp (+ (ash 1 n-widetag-bits)
173 (inst b? (if not-p :ne :eq) target)
174 (emit-label not-target)))))
176 (define-vop (check-signed-byte-32 check-type)
178 (let ((nope (generate-error-code vop 'object-not-signed-byte-32-error value))
180 (inst andi. temp value fixnum-tag-mask)
182 (test-type value nope t (other-pointer-lowtag) :temp temp)
183 (loadw temp value 0 other-pointer-lowtag)
184 (inst cmpwi temp (+ (ash 1 n-widetag-bits) bignum-widetag))
187 (move result value))))
190 ;;; An (unsigned-byte 32) can be represented with either a positive fixnum, a
191 ;;; bignum with exactly one positive digit, or a bignum with exactly two digits
192 ;;; and the second digit all zeros.
194 (define-vop (unsigned-byte-32-p type-predicate)
195 (:translate unsigned-byte-32-p)
197 (let ((not-target (gen-label))
198 (single-word (gen-label))
199 (fixnum (gen-label)))
203 (values not-target target)
204 (values target not-target))
206 (inst andi. temp value fixnum-tag-mask)
207 (inst cmpwi :cr1 value 0)
210 ;; If not, is it an other pointer?
211 (test-type value nope t (other-pointer-lowtag) :temp temp)
213 (loadw temp value 0 other-pointer-lowtag)
215 (inst cmpwi temp (+ (ash 1 n-widetag-bits) bignum-widetag))
216 (inst beq single-word)
217 ;; If it's other than two, we can't be an (unsigned-byte 32)
218 (inst cmpwi temp (+ (ash 2 n-widetag-bits) bignum-widetag))
220 ;; Get the second digit.
221 (loadw temp value (1+ bignum-digits-offset) other-pointer-lowtag)
222 ;; All zeros, its an (unsigned-byte 32).
225 ;; Otherwise, it isn't.
228 (emit-label single-word)
229 ;; Get the single digit.
230 (loadw temp value bignum-digits-offset other-pointer-lowtag)
231 (inst cmpwi :cr1 temp 0)
233 ;; positive implies (unsigned-byte 32).
235 (inst b? :cr1 (if not-p :lt :ge) target)
237 (emit-label not-target)))))
239 (define-vop (check-unsigned-byte-32 check-type)
242 (generate-error-code vop 'object-not-unsigned-byte-32-error value))
245 (single-word (gen-label)))
247 (inst andi. temp value fixnum-tag-mask)
248 (inst cmpwi :cr1 value 0)
251 ;; If not, is it an other pointer?
252 (test-type value nope t (other-pointer-lowtag) :temp temp)
253 ;; Get the number of digits.
254 (loadw temp value 0 other-pointer-lowtag)
256 (inst cmpwi temp (+ (ash 1 n-widetag-bits) bignum-widetag))
257 (inst beq single-word)
258 ;; If it's other than two, we can't be an (unsigned-byte 32)
259 (inst cmpwi temp (+ (ash 2 n-widetag-bits) bignum-widetag))
261 ;; Get the second digit.
262 (loadw temp value (1+ bignum-digits-offset) other-pointer-lowtag)
263 ;; All zeros, its an (unsigned-byte 32).
266 ;; 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).
273 (inst cmpwi :cr1 temp 0)
279 (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 cmpw value null-tn)
295 (inst beq 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 cmpw value null-tn)
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 cmpw value null-tn)
315 (inst beq 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 cmpw value null-tn)
324 (test-type value error t (list-pointer-lowtag) :temp temp)
325 (move result value))))