1 ;;;; type testing and checking VOPs for the HPPA 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)
16 (declare (ignore temp))
18 (inst extru value 31 2 zero-tn (if not-p := :<>))
19 (inst b target :nullify t)))
21 (defun %test-fixnum-and-headers (value target not-p headers &key temp)
22 (let ((drop-through (gen-label)))
24 (inst extru value 31 2 zero-tn :<>)
25 (inst b (if not-p drop-through target) :nullify t))
26 (%test-headers value target not-p nil headers
27 :drop-through drop-through :temp temp)))
29 (defun %test-immediate (value target not-p immediate &key temp)
31 (inst extru value 31 8 temp)
32 (inst bci := not-p immediate temp target)))
34 (defun %test-lowtag (value target not-p lowtag
35 &key temp temp-loaded)
38 (inst extru value 31 3 temp))
39 (inst bci := not-p lowtag temp target)))
41 (defun %test-lowtag-and-headers (value target not-p lowtag
42 function-p headers &key temp)
43 (let ((drop-through (gen-label)))
44 (%test-lowtag value (if not-p drop-through target) nil lowtag
46 (%test-headers value target not-p function-p headers
47 :drop-through drop-through :temp temp :temp-loaded t)))
49 (defun %test-headers (value target not-p function-p headers
50 &key temp (drop-through (gen-label)) temp-loaded)
51 (let ((lowtag (if function-p fun-pointer-lowtag other-pointer-lowtag)))
53 (equal greater-or-equal when-true when-false)
54 ;; EQUAL and GREATER-OR-EQUAL are the conditions for branching to
55 ;; TARGET. WHEN-TRUE and WHEN-FALSE are the labels to branch to when
56 ;; we know it's true and when we know it's false respectively.
58 (values :<> :< drop-through target)
59 (values := :>= target drop-through))
61 (%test-lowtag value when-false t lowtag
62 :temp temp :temp-loaded temp-loaded)
63 (inst ldb (- 3 lowtag) value temp)
64 (do ((remaining headers (cdr remaining)))
66 (let ((header (car remaining))
67 (last (null (cdr remaining))))
71 (inst bci equal nil header temp target)
72 (inst bci := nil header temp when-true)))
74 (let ((start (car header))
76 (unless (= start bignum-widetag)
77 (inst bci :> nil start temp when-false))
79 (inst bci greater-or-equal nil end temp target)
80 (inst bci :>= nil end temp when-true)))))))
81 (emit-label drop-through)))))
83 ;;;; Type checking and testing:
85 (define-vop (check-type)
86 (:args (value :target result :scs (any-reg descriptor-reg)))
87 (:results (result :scs (any-reg descriptor-reg)))
88 (:temporary (:scs (non-descriptor-reg) :to (:result 0)) temp)
90 (:save-p :compute-only))
92 (define-vop (type-predicate)
93 (:args (value :scs (any-reg descriptor-reg)))
94 (:temporary (:scs (non-descriptor-reg)) temp)
99 (defun cost-to-test-types (type-codes)
100 (+ (* 2 (length type-codes))
101 (if (> (apply #'max type-codes) lowtag-limit) 7 2)))
103 (defmacro !define-type-vops (pred-name check-name ptype error-code
105 &key &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 (generate-error-code vop ,error-code value)))
118 (test-type value err-lab t (,@type-codes) :temp temp)
119 (move value result))))))
121 `((primitive-type-vop ,check-name (:check) ,ptype))))))
123 ;;;; Other integer ranges.
125 ;;; A (signed-byte 32) can be represented with either fixnum or a bignum with
126 ;;; exactly one digit.
128 (defun signed-byte-32-test (value temp not-p target not-target)
132 (values not-target target)
133 (values target not-target))
135 (inst extru value 31 2 zero-tn :<>)
136 (inst b yep :nullify t)
137 (inst extru value 31 3 temp)
138 (inst bci :<> nil other-pointer-lowtag temp nope)
139 (loadw temp value 0 other-pointer-lowtag)
140 (inst bci := not-p (+ (ash 1 n-widetag-bits) bignum-widetag) temp target)))
143 (define-vop (signed-byte-32-p type-predicate)
144 (:translate signed-byte-32-p)
146 (signed-byte-32-test value temp not-p target not-target)
149 (define-vop (check-signed-byte-32 check-type)
151 (let ((loose (generate-error-code vop object-not-signed-byte-32-error
153 (signed-byte-32-test value temp t loose okay))
155 (move value result)))
157 ;;; An (unsigned-byte 32) can be represented with either a positive fixnum, a
158 ;;; bignum with exactly one positive digit, or a bignum with exactly two digits
159 ;;; and the second digit all zeros.
161 (defun unsigned-byte-32-test (value temp not-p target not-target)
162 (let ((nope (if not-p target not-target)))
165 (inst extru value 31 2 zero-tn :<>)
167 (inst move value temp)
169 ;; If not, is it an other pointer?
170 (inst extru value 31 3 temp)
171 (inst bci :<> nil other-pointer-lowtag temp nope)
173 (loadw temp value 0 other-pointer-lowtag)
175 (inst bci := nil (+ (ash 1 n-widetag-bits) bignum-widetag) temp single-word)
176 ;; If it's other than two, we can't be an (unsigned-byte 32)
177 (inst bci :<> nil (+ (ash 2 n-widetag-bits) bignum-widetag) temp nope)
178 ;; Get the second digit.
179 (loadw temp value (1+ bignum-digits-offset) other-pointer-lowtag)
180 ;; All zeros, its an (unsigned-byte 32).
181 (inst comb (if not-p := :<>) temp zero-tn not-target :nullify t)
182 (inst b target :nullify t)
185 ;; Get the single digit.
186 (loadw temp value bignum-digits-offset other-pointer-lowtag)
188 ;; positive implies (unsigned-byte 32).
190 (inst bc :>= not-p temp zero-tn target)))
193 (define-vop (unsigned-byte-32-p type-predicate)
194 (:translate unsigned-byte-32-p)
196 (unsigned-byte-32-test value temp not-p target not-target)
199 (define-vop (check-unsigned-byte-32 check-type)
201 (let ((loose (generate-error-code vop object-not-unsigned-byte-32-error
203 (unsigned-byte-32-test value temp t loose okay))
205 (move value result)))
208 ;;;; List/symbol types:
210 ;;; symbolp (or symbol (eq nil))
211 ;;; consp (and list (not (eq nil)))
213 (define-vop (symbolp type-predicate)
216 (inst bc := nil value null-tn (if not-p drop-thru target))
217 (test-type value target not-p (symbol-header-widetag) :temp temp)
220 (define-vop (check-symbol check-type)
222 (inst comb := value null-tn drop-thru)
223 (let ((error (generate-error-code vop object-not-symbol-error value)))
224 (test-type value error t (symbol-header-widetag) :temp temp))
226 (move value result)))
228 (define-vop (consp type-predicate)
231 (inst bc := nil value null-tn (if not-p target drop-thru))
232 (test-type value target not-p (list-pointer-lowtag) :temp temp)
235 (define-vop (check-cons check-type)
237 (let ((error (generate-error-code vop object-not-cons-error value)))
238 (inst bc := nil value null-tn error)
239 (test-type value error t (list-pointer-lowtag) :temp temp))
240 (move value result)))