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 ;; FIXME: again, this 3 should be FIXNUM-MASK
17 (inst andi. temp value 3)
18 (inst b? (if not-p :ne :eq) target)))
20 (defun %test-fixnum-and-headers (value target not-p headers &key temp)
21 (let ((drop-through (gen-label)))
23 (inst andi. temp value 3)
24 (inst beq (if not-p drop-through target)))
25 (%test-headers value target not-p nil headers
26 :drop-through drop-through :temp temp)))
28 (defun %test-immediate (value target not-p immediate &key temp)
30 (inst andi. temp value widetag-mask)
31 (inst cmpwi temp immediate)
32 (inst b? (if not-p :ne :eq) target)))
34 (defun %test-lowtag (value target not-p lowtag &key temp)
36 (inst andi. temp value lowtag-mask)
37 (inst cmpwi temp lowtag)
38 (inst b? (if not-p :ne :eq) target)))
40 (defun %test-lowtag-and-headers (value target not-p lowtag function-p headers
42 (let ((drop-through (gen-label)))
43 (%test-lowtag value (if not-p drop-through target) not-p lowtag
45 (%test-headers value target not-p function-p headers
46 :temp temp :drop-through drop-through)))
48 (defun %test-headers (value target not-p function-p headers
49 &key temp (drop-through (gen-label)))
50 (let ((lowtag (if function-p fun-pointer-lowtag other-pointer-lowtag)))
51 (multiple-value-bind (when-true when-false)
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))
58 (do ((remaining headers (cdr remaining)))
60 (let ((header (car remaining))
61 (last (null (cdr remaining))))
64 (inst cmpwi temp header)
66 (inst b? (if not-p :ne :eq) target)
67 (inst beq when-true)))
69 (let ((start (car header))
71 (unless (= start bignum-widetag)
72 (inst cmpwi temp start)
73 (inst blt when-false))
76 (inst b? (if not-p :gt :le) target)
77 (inst ble when-true)))))))
78 (emit-label drop-through)))))
80 ;;; Simple type checking and testing:
81 (define-vop (check-type)
82 (:args (value :target result :scs (any-reg descriptor-reg)))
83 (:results (result :scs (any-reg descriptor-reg)))
84 (:temporary (:scs (non-descriptor-reg)) temp)
86 (:save-p :compute-only))
88 (define-vop (type-predicate)
89 (:args (value :scs (any-reg descriptor-reg)))
93 (:temporary (:scs (non-descriptor-reg)) temp))
95 (defun cost-to-test-types (type-codes)
96 (+ (* 2 (length type-codes))
97 (if (> (apply #'max type-codes) lowtag-limit) 7 2)))
99 (defmacro !define-type-vops (pred-name check-name ptype error-code
101 ;; KLUDGE: ideally, the compiler could
102 ;; derive that it can use the sneaky trap
103 ;; twice mechanism itself. However, one
104 ;; thing at a time...
105 &key mask &allow-other-keys)
106 (let ((cost (cost-to-test-types (mapcar #'eval type-codes))))
109 `((define-vop (,pred-name type-predicate)
110 (:translate ,pred-name)
112 (test-type value target not-p (,@type-codes) :temp temp)))))
114 `((define-vop (,check-name check-type)
117 `((inst andi. temp value ,mask)
118 (inst twi 0 value (error-number-or-lose ',error-code))
119 (inst twi :ne temp ,@(if ;; KLUDGE: At
128 (generate-error-code vop ,error-code value)))
129 (test-type value err-lab t (,@type-codes) :temp temp)
130 (move result value))))))))
132 `((primitive-type-vop ,check-name (:check) ,ptype))))))
134 ;;;; Other integer ranges.
136 ;;; A (signed-byte 32) can be represented with either fixnum or a bignum with
137 ;;; exactly one digit.
139 (define-vop (signed-byte-32-p type-predicate)
140 (:translate signed-byte-32-p)
142 (let ((not-target (gen-label)))
146 (values not-target target)
147 (values target not-target))
148 (inst andi. temp value #x3)
150 (test-type value nope t (other-pointer-lowtag) :temp temp)
151 (loadw temp value 0 other-pointer-lowtag)
152 (inst cmpwi temp (+ (ash 1 n-widetag-bits)
154 (inst b? (if not-p :ne :eq) target)
155 (emit-label not-target)))))
157 (define-vop (check-signed-byte-32 check-type)
159 (let ((nope (generate-error-code vop object-not-signed-byte-32-error value))
161 (inst andi. temp value #x3)
163 (test-type value nope t (other-pointer-lowtag) :temp temp)
164 (loadw temp value 0 other-pointer-lowtag)
165 (inst cmpwi temp (+ (ash 1 n-widetag-bits) bignum-widetag))
168 (move result value))))
171 ;;; An (unsigned-byte 32) can be represented with either a positive fixnum, a
172 ;;; bignum with exactly one positive digit, or a bignum with exactly two digits
173 ;;; and the second digit all zeros.
175 (define-vop (unsigned-byte-32-p type-predicate)
176 (:translate unsigned-byte-32-p)
178 (let ((not-target (gen-label))
179 (single-word (gen-label))
180 (fixnum (gen-label)))
184 (values not-target target)
185 (values target not-target))
187 (inst andi. temp value #x3)
188 (inst cmpwi :cr1 value 0)
191 ;; If not, is it an other pointer?
192 (test-type value nope t (other-pointer-lowtag) :temp temp)
194 (loadw temp value 0 other-pointer-lowtag)
196 (inst cmpwi temp (+ (ash 1 n-widetag-bits) bignum-widetag))
197 (inst beq single-word)
198 ;; If it's other than two, we can't be an (unsigned-byte 32)
199 (inst cmpwi temp (+ (ash 2 n-widetag-bits) bignum-widetag))
201 ;; Get the second digit.
202 (loadw temp value (1+ bignum-digits-offset) other-pointer-lowtag)
203 ;; All zeros, its an (unsigned-byte 32).
206 ;; Otherwise, it isn't.
209 (emit-label single-word)
210 ;; Get the single digit.
211 (loadw temp value bignum-digits-offset other-pointer-lowtag)
212 (inst cmpwi :cr1 temp 0)
214 ;; positive implies (unsigned-byte 32).
216 (inst b? :cr1 (if not-p :lt :ge) target)
218 (emit-label not-target)))))
220 (define-vop (check-unsigned-byte-32 check-type)
223 (generate-error-code vop object-not-unsigned-byte-32-error value))
226 (single-word (gen-label)))
228 (inst andi. temp value #x3)
229 (inst cmpwi :cr1 value 0)
232 ;; If not, is it an other pointer?
233 (test-type value nope t (other-pointer-lowtag) :temp temp)
234 ;; Get the number of digits.
235 (loadw temp value 0 other-pointer-lowtag)
237 (inst cmpwi temp (+ (ash 1 n-widetag-bits) bignum-widetag))
238 (inst beq single-word)
239 ;; If it's other than two, we can't be an (unsigned-byte 32)
240 (inst cmpwi temp (+ (ash 2 n-widetag-bits) bignum-widetag))
242 ;; Get the second digit.
243 (loadw temp value (1+ bignum-digits-offset) other-pointer-lowtag)
244 ;; All zeros, its an (unsigned-byte 32).
247 ;; Otherwise, it isn't.
250 (emit-label single-word)
251 ;; Get the single digit.
252 (loadw temp value bignum-digits-offset other-pointer-lowtag)
253 ;; positive implies (unsigned-byte 32).
254 (inst cmpwi :cr1 temp 0)
260 (move result value))))
265 ;;;; List/symbol types:
267 ;;; symbolp (or symbol (eq nil))
268 ;;; consp (and list (not (eq nil)))
270 (define-vop (symbolp type-predicate)
273 (let* ((drop-thru (gen-label))
274 (is-symbol-label (if not-p drop-thru target)))
275 (inst cmpw value null-tn)
276 (inst beq is-symbol-label)
277 (test-type value target not-p (symbol-header-widetag) :temp temp)
278 (emit-label drop-thru))))
280 (define-vop (check-symbol check-type)
282 (let ((drop-thru (gen-label))
283 (error (generate-error-code vop object-not-symbol-error value)))
284 (inst cmpw value null-tn)
286 (test-type value error t (symbol-header-widetag) :temp temp)
287 (emit-label drop-thru)
288 (move result value))))
290 (define-vop (consp type-predicate)
293 (let* ((drop-thru (gen-label))
294 (is-not-cons-label (if not-p target drop-thru)))
295 (inst cmpw value null-tn)
296 (inst beq is-not-cons-label)
297 (test-type value target not-p (list-pointer-lowtag) :temp temp)
298 (emit-label drop-thru))))
300 (define-vop (check-cons check-type)
302 (let ((error (generate-error-code vop object-not-cons-error value)))
303 (inst cmpw value null-tn)
305 (test-type value error t (list-pointer-lowtag) :temp temp)
306 (move result value))))