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-headers (value target not-p function-p headers
42 &key temp (drop-through (gen-label)) temp-loaded)
43 (let ((lowtag (if function-p fun-pointer-lowtag other-pointer-lowtag)))
45 (equal greater-or-equal when-true when-false)
46 ;; EQUAL and GREATER-OR-EQUAL are the conditions for branching to
47 ;; TARGET. WHEN-TRUE and WHEN-FALSE are the labels to branch to when
48 ;; we know it's true and when we know it's false respectively.
50 (values :<> :< drop-through target)
51 (values := :>= target drop-through))
53 (%test-lowtag value when-false t lowtag
54 :temp temp :temp-loaded temp-loaded)
55 (inst ldb (- 3 lowtag) value temp)
56 (do ((remaining headers (cdr remaining)))
58 (let ((header (car remaining))
59 (last (null (cdr remaining))))
63 (inst bci equal nil header temp target)
64 (inst bci := nil header temp when-true)))
66 (let ((start (car header))
68 (unless (= start bignum-widetag)
69 (inst bci :> nil start temp when-false))
71 (inst bci greater-or-equal nil end temp target)
72 (inst bci :>= nil end temp when-true)))))))
73 (emit-label drop-through)))))
75 ;;;; Type checking and testing:
77 (define-vop (check-type)
78 (:args (value :target result :scs (any-reg descriptor-reg)))
79 (:results (result :scs (any-reg descriptor-reg)))
80 (:temporary (:scs (non-descriptor-reg) :to (:result 0)) temp)
82 (:save-p :compute-only))
84 (define-vop (type-predicate)
85 (:args (value :scs (any-reg descriptor-reg)))
86 (:temporary (:scs (non-descriptor-reg)) temp)
91 (defun cost-to-test-types (type-codes)
92 (+ (* 2 (length type-codes))
93 (if (> (apply #'max type-codes) lowtag-limit) 7 2)))
95 (defmacro !define-type-vops (pred-name check-name ptype error-code
97 &key &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 (generate-error-code vop ,error-code value)))
110 (test-type value err-lab t (,@type-codes) :temp temp)
111 (move value result))))))
113 `((primitive-type-vop ,check-name (:check) ,ptype))))))
115 ;;;; Other integer ranges.
117 ;;; A (signed-byte 32) can be represented with either fixnum or a bignum with
118 ;;; exactly one digit.
120 (defun signed-byte-32-test (value temp not-p target not-target)
124 (values not-target target)
125 (values target not-target))
127 (inst extru value 31 2 zero-tn :<>)
128 (inst b yep :nullify t)
129 (inst extru value 31 3 temp)
130 (inst bci :<> nil other-pointer-lowtag temp nope)
131 (loadw temp value 0 other-pointer-lowtag)
132 (inst bci := not-p (+ (ash 1 n-widetag-bits) bignum-widetag) temp target)))
135 (define-vop (signed-byte-32-p type-predicate)
136 (:translate signed-byte-32-p)
138 (signed-byte-32-test value temp not-p target not-target)
141 (define-vop (check-signed-byte-32 check-type)
143 (let ((loose (generate-error-code vop object-not-signed-byte-32-error
145 (signed-byte-32-test value temp t loose okay))
147 (move value result)))
149 ;;; An (unsigned-byte 32) can be represented with either a positive fixnum, a
150 ;;; bignum with exactly one positive digit, or a bignum with exactly two digits
151 ;;; and the second digit all zeros.
153 (defun unsigned-byte-32-test (value temp not-p target not-target)
154 (let ((nope (if not-p target not-target)))
157 (inst extru value 31 2 zero-tn :<>)
159 (inst move value temp)
161 ;; If not, is it an other pointer?
162 (inst extru value 31 3 temp)
163 (inst bci :<> nil other-pointer-lowtag temp nope)
165 (loadw temp value 0 other-pointer-lowtag)
167 (inst bci := nil (+ (ash 1 n-widetag-bits) bignum-widetag) temp single-word)
168 ;; If it's other than two, we can't be an (unsigned-byte 32)
169 (inst bci :<> nil (+ (ash 2 n-widetag-bits) bignum-widetag) temp nope)
170 ;; Get the second digit.
171 (loadw temp value (1+ bignum-digits-offset) other-pointer-lowtag)
172 ;; All zeros, its an (unsigned-byte 32).
173 (inst comb (if not-p := :<>) temp zero-tn not-target :nullify t)
174 (inst b target :nullify t)
177 ;; Get the single digit.
178 (loadw temp value bignum-digits-offset other-pointer-lowtag)
180 ;; positive implies (unsigned-byte 32).
182 (inst bc :>= not-p temp zero-tn target)))
185 (define-vop (unsigned-byte-32-p type-predicate)
186 (:translate unsigned-byte-32-p)
188 (unsigned-byte-32-test value temp not-p target not-target)
191 (define-vop (check-unsigned-byte-32 check-type)
193 (let ((loose (generate-error-code vop object-not-unsigned-byte-32-error
195 (unsigned-byte-32-test value temp t loose okay))
197 (move value result)))
200 ;;;; List/symbol types:
202 ;;; symbolp (or symbol (eq nil))
203 ;;; consp (and list (not (eq nil)))
205 (define-vop (symbolp type-predicate)
208 (inst bc := nil value null-tn (if not-p drop-thru target))
209 (test-type value target not-p (symbol-header-widetag) :temp temp)
212 (define-vop (check-symbol check-type)
214 (inst comb := value null-tn drop-thru)
215 (let ((error (generate-error-code vop object-not-symbol-error value)))
216 (test-type value error t (symbol-header-widetag) :temp temp))
218 (move value result)))
220 (define-vop (consp type-predicate)
223 (inst bc := nil value null-tn (if not-p target drop-thru))
224 (test-type value target not-p (list-pointer-lowtag) :temp temp)
227 (define-vop (check-cons check-type)
229 (let ((error (generate-error-code vop object-not-cons-error value)))
230 (inst bc := nil value null-tn error)
231 (test-type value error t (list-pointer-lowtag) :temp temp))
232 (move value result)))