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-headers (value target not-p function-p headers
41 &key temp (drop-through (gen-label)))
42 (let ((lowtag (if function-p fun-pointer-lowtag other-pointer-lowtag)))
43 (multiple-value-bind (when-true when-false)
45 (values drop-through target)
46 (values target drop-through))
48 (%test-lowtag value when-false t lowtag :temp temp)
49 (load-type temp value (- lowtag))
50 (do ((remaining headers (cdr remaining)))
52 (let ((header (car remaining))
53 (last (null (cdr remaining))))
56 (inst cmpwi temp header)
58 (inst b? (if not-p :ne :eq) target)
59 (inst beq when-true)))
61 (let ((start (car header))
63 (unless (= start bignum-widetag)
64 (inst cmpwi temp start)
65 (inst blt when-false))
68 (inst b? (if not-p :gt :le) target)
69 (inst ble when-true)))))))
70 (emit-label drop-through)))))
72 ;;; Simple type checking and testing:
73 (define-vop (check-type)
74 (:args (value :target result :scs (any-reg descriptor-reg)))
75 (:results (result :scs (any-reg descriptor-reg)))
76 (:temporary (:scs (non-descriptor-reg)) temp)
78 (:save-p :compute-only))
80 (define-vop (type-predicate)
81 (:args (value :scs (any-reg descriptor-reg)))
85 (:temporary (:scs (non-descriptor-reg)) temp))
87 (defun cost-to-test-types (type-codes)
88 (+ (* 2 (length type-codes))
89 (if (> (apply #'max type-codes) lowtag-limit) 7 2)))
91 (defmacro !define-type-vops (pred-name check-name ptype error-code
93 ;; KLUDGE: ideally, the compiler could
94 ;; derive that it can use the sneaky trap
95 ;; twice mechanism itself. However, one
97 &key mask &allow-other-keys)
98 (let ((cost (cost-to-test-types (mapcar #'eval type-codes))))
101 `((define-vop (,pred-name type-predicate)
102 (:translate ,pred-name)
104 (test-type value target not-p (,@type-codes) :temp temp)))))
106 `((define-vop (,check-name check-type)
109 `((inst andi. temp value ,mask)
110 (inst twi 0 value (error-number-or-lose ',error-code))
111 (inst twi :ne temp ,@(if ;; KLUDGE: At
120 (generate-error-code vop ,error-code value)))
121 (test-type value err-lab t (,@type-codes) :temp temp)
122 (move result value))))))))
124 `((primitive-type-vop ,check-name (:check) ,ptype))))))
126 ;;;; Other integer ranges.
128 ;;; A (signed-byte 32) can be represented with either fixnum or a bignum with
129 ;;; exactly one digit.
131 (define-vop (signed-byte-32-p type-predicate)
132 (:translate signed-byte-32-p)
134 (let ((not-target (gen-label)))
138 (values not-target target)
139 (values target not-target))
140 (inst andi. temp value #x3)
142 (test-type value nope t (other-pointer-lowtag) :temp temp)
143 (loadw temp value 0 other-pointer-lowtag)
144 (inst cmpwi temp (+ (ash 1 n-widetag-bits)
146 (inst b? (if not-p :ne :eq) target)
147 (emit-label not-target)))))
149 (define-vop (check-signed-byte-32 check-type)
151 (let ((nope (generate-error-code vop object-not-signed-byte-32-error value))
153 (inst andi. temp value #x3)
155 (test-type value nope t (other-pointer-lowtag) :temp temp)
156 (loadw temp value 0 other-pointer-lowtag)
157 (inst cmpwi temp (+ (ash 1 n-widetag-bits) bignum-widetag))
160 (move result value))))
163 ;;; An (unsigned-byte 32) can be represented with either a positive fixnum, a
164 ;;; bignum with exactly one positive digit, or a bignum with exactly two digits
165 ;;; and the second digit all zeros.
167 (define-vop (unsigned-byte-32-p type-predicate)
168 (:translate unsigned-byte-32-p)
170 (let ((not-target (gen-label))
171 (single-word (gen-label))
172 (fixnum (gen-label)))
176 (values not-target target)
177 (values target not-target))
179 (inst andi. temp value #x3)
180 (inst cmpwi :cr1 value 0)
183 ;; If not, is it an other pointer?
184 (test-type value nope t (other-pointer-lowtag) :temp temp)
186 (loadw temp value 0 other-pointer-lowtag)
188 (inst cmpwi temp (+ (ash 1 n-widetag-bits) bignum-widetag))
189 (inst beq single-word)
190 ;; If it's other than two, we can't be an (unsigned-byte 32)
191 (inst cmpwi temp (+ (ash 2 n-widetag-bits) bignum-widetag))
193 ;; Get the second digit.
194 (loadw temp value (1+ bignum-digits-offset) other-pointer-lowtag)
195 ;; All zeros, its an (unsigned-byte 32).
198 ;; Otherwise, it isn't.
201 (emit-label single-word)
202 ;; Get the single digit.
203 (loadw temp value bignum-digits-offset other-pointer-lowtag)
204 (inst cmpwi :cr1 temp 0)
206 ;; positive implies (unsigned-byte 32).
208 (inst b? :cr1 (if not-p :lt :ge) target)
210 (emit-label not-target)))))
212 (define-vop (check-unsigned-byte-32 check-type)
215 (generate-error-code vop object-not-unsigned-byte-32-error value))
218 (single-word (gen-label)))
220 (inst andi. temp value #x3)
221 (inst cmpwi :cr1 value 0)
224 ;; If not, is it an other pointer?
225 (test-type value nope t (other-pointer-lowtag) :temp temp)
226 ;; Get the number of digits.
227 (loadw temp value 0 other-pointer-lowtag)
229 (inst cmpwi temp (+ (ash 1 n-widetag-bits) bignum-widetag))
230 (inst beq single-word)
231 ;; If it's other than two, we can't be an (unsigned-byte 32)
232 (inst cmpwi temp (+ (ash 2 n-widetag-bits) bignum-widetag))
234 ;; Get the second digit.
235 (loadw temp value (1+ bignum-digits-offset) other-pointer-lowtag)
236 ;; All zeros, its an (unsigned-byte 32).
239 ;; Otherwise, it isn't.
242 (emit-label single-word)
243 ;; Get the single digit.
244 (loadw temp value bignum-digits-offset other-pointer-lowtag)
245 ;; positive implies (unsigned-byte 32).
246 (inst cmpwi :cr1 temp 0)
252 (move result value))))
257 ;;;; List/symbol types:
259 ;;; symbolp (or symbol (eq nil))
260 ;;; consp (and list (not (eq nil)))
262 (define-vop (symbolp type-predicate)
265 (let* ((drop-thru (gen-label))
266 (is-symbol-label (if not-p drop-thru target)))
267 (inst cmpw value null-tn)
268 (inst beq is-symbol-label)
269 (test-type value target not-p (symbol-header-widetag) :temp temp)
270 (emit-label drop-thru))))
272 (define-vop (check-symbol check-type)
274 (let ((drop-thru (gen-label))
275 (error (generate-error-code vop object-not-symbol-error value)))
276 (inst cmpw value null-tn)
278 (test-type value error t (symbol-header-widetag) :temp temp)
279 (emit-label drop-thru)
280 (move result value))))
282 (define-vop (consp type-predicate)
285 (let* ((drop-thru (gen-label))
286 (is-not-cons-label (if not-p target drop-thru)))
287 (inst cmpw value null-tn)
288 (inst beq is-not-cons-label)
289 (test-type value target not-p (list-pointer-lowtag) :temp temp)
290 (emit-label drop-thru))))
292 (define-vop (check-cons check-type)
294 (let ((error (generate-error-code vop object-not-cons-error value)))
295 (inst cmpw value null-tn)
297 (test-type value error t (list-pointer-lowtag) :temp temp)
298 (move result value))))