1 ;;;; type testing and checking VOPs for the MIPS 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 ;;; Test generation utilities.
15 (defun %test-fixnum
(value target not-p
&key temp
)
17 (inst and temp value fixnum-tag-mask
)
19 (inst bne temp target
)
20 (inst beq temp target
))
23 (defun %test-fixnum-and-headers
(value target not-p headers
&key temp
)
24 (let ((drop-through (gen-label)))
26 (inst and temp value fixnum-tag-mask
)
27 (inst beq temp
(if not-p drop-through target
)))
28 (%test-headers value target not-p nil headers
29 :drop-through drop-through
:temp temp
)))
31 (defun %test-immediate
(value target not-p immediate
&key temp
)
33 (inst and temp value widetag-mask
)
34 (inst xor temp immediate
)
36 (inst bne temp target
)
37 (inst beq temp target
))
40 (defun %test-lowtag
(value target not-p lowtag
&key temp
)
42 (inst and temp value lowtag-mask
)
43 (inst xor temp lowtag
)
45 (inst bne temp target
)
46 (inst beq temp target
))
49 (defun %test-headers
(value target not-p function-p headers
50 &key
(drop-through (gen-label)) temp
)
51 (let ((lowtag (if function-p fun-pointer-lowtag other-pointer-lowtag
)))
53 (when-true when-false
)
54 ;; WHEN-TRUE and WHEN-FALSE are the labels to branch to when
55 ;; we know it's true and when we know it's false respectively.
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
))
64 (do ((remaining headers
(cdr remaining
)))
66 (let ((header (car remaining
))
67 (last (null (cdr remaining
))))
70 (inst subu temp
(- header delta
))
74 (inst bne temp target
)
75 (inst beq temp target
))
76 (inst beq temp when-true
)))
78 (let ((start (car header
))
80 (unless (= start bignum-widetag
)
81 (inst subu temp
(- start delta
))
83 (inst bltz temp when-false
))
84 (inst subu temp
(- end delta
))
88 (inst bgtz temp target
)
89 (inst blez temp target
))
90 (inst blez temp when-true
))))))))
92 (emit-label drop-through
)))))
94 ;;;; TYPE-VOPs for types that are more complex to test for than simple
95 ;;;; LOWTAG and WIDETAG tests, but that are nevertheless important:
97 ;;; A (SIGNED-BYTE 32) can be represented with either fixnum or a
98 ;;; bignum with exactly one digit.
99 (defun signed-byte-32-test (value temp not-p target not-target
)
103 (values not-target target
)
104 (values target not-target
))
106 (inst and temp value fixnum-tag-mask
)
108 (inst and temp value lowtag-mask
)
109 (inst xor temp other-pointer-lowtag
)
112 (loadw temp value
0 other-pointer-lowtag
)
113 (inst xor temp
(+ (ash 1 n-widetag-bits
) bignum-widetag
))
115 (inst bne temp target
)
116 (inst beq temp target
))
120 (define-vop (signed-byte-32-p type-predicate
)
121 (:translate signed-byte-32-p
)
123 (signed-byte-32-test value temp not-p target not-target
)
126 ;;; An (UNSIGNED-BYTE 32) can be represented with either a positive
127 ;;; fixnum, a bignum with exactly one positive digit, or a bignum with
128 ;;; exactly two digits and the second digit all zeros.
129 (defun unsigned-byte-32-test (value temp not-p target not-target
)
130 (multiple-value-bind (yep nope
)
132 (values not-target target
)
133 (values target not-target
))
136 (inst and temp value fixnum-tag-mask
)
137 (inst beq temp fixnum
)
140 ;; If not, is it an other pointer?
141 (inst and temp value lowtag-mask
)
142 (inst xor temp other-pointer-lowtag
)
146 (loadw temp value
0 other-pointer-lowtag
)
148 (inst xor temp
(+ (ash 1 n-widetag-bits
) bignum-widetag
))
149 (inst beq temp single-word
)
150 ;; If it's other than two, we can't be an (unsigned-byte 32)
151 (inst xor temp
(logxor (+ (ash 1 n-widetag-bits
) bignum-widetag
)
152 (+ (ash 2 n-widetag-bits
) bignum-widetag
)))
154 ;; Get the second digit.
155 (loadw temp value
(1+ bignum-digits-offset
) other-pointer-lowtag
)
156 ;; All zeros, its an (unsigned-byte 32).
162 ;; Get the single digit.
163 (loadw temp value bignum-digits-offset other-pointer-lowtag
)
165 ;; positive implies (unsigned-byte 32).
168 (inst bltz temp target
)
169 (inst bgez temp target
))
173 (define-vop (unsigned-byte-32-p type-predicate
)
174 (:translate unsigned-byte-32-p
)
176 (unsigned-byte-32-test value temp not-p target not-target
)
179 ;;; Because of our LOWTAG representation, SYMBOLP and CONSP are
180 ;;; slightly more complex:
182 ;;; * SYMBOLP is true if the object has SYMBOL-WIDETAG or is EQ
185 ;;; * CONSP is true if the object has LIST-POINTER-LOWTAG and is not
188 ;;; [ FIXME: This comment should not really be here, in the bowels of
189 ;;; the MIPS type-vops, but where should it be?]
190 (define-vop (symbolp type-predicate
)
193 (inst beq value null-tn
(if not-p drop-thru target
))
194 (test-type value target not-p
(symbol-widetag) :temp temp
)
197 (define-vop (consp type-predicate
)
200 (inst beq value null-tn
(if not-p target drop-thru
))
201 (test-type value target not-p
(list-pointer-lowtag) :temp temp
)