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 &key temp temp-loaded)
37 (inst extru value 31 3 temp))
38 (inst bci := not-p lowtag temp target)))
40 (defun %test-headers (value target not-p function-p headers
41 &key temp (drop-through (gen-label)) temp-loaded)
42 (let ((lowtag (if function-p fun-pointer-lowtag other-pointer-lowtag)))
44 (equal greater-or-equal when-true when-false)
45 ;; EQUAL and GREATER-OR-EQUAL are the conditions for branching to
46 ;; TARGET. WHEN-TRUE and WHEN-FALSE are the labels to branch to when
47 ;; we know it's true and when we know it's false respectively.
49 (values :<> :< drop-through target)
50 (values := :>= target drop-through))
52 (%test-lowtag value when-false t lowtag
53 :temp temp :temp-loaded temp-loaded)
54 (inst ldb (- 3 lowtag) value temp)
55 (do ((remaining headers (cdr remaining)))
57 (let ((header (car remaining))
58 (last (null (cdr remaining))))
62 (inst bci equal nil header temp target)
63 (inst bci := nil header temp when-true)))
65 (let ((start (car header))
67 (unless (= start bignum-widetag)
68 (inst bci :> nil start temp when-false))
70 (inst bci greater-or-equal nil end temp target)
71 (inst bci :>= nil end temp when-true)))))))
72 (emit-label drop-through)))))
74 ;;;; Type checking and testing:
76 (define-vop (check-type)
77 (:args (value :target result :scs (any-reg descriptor-reg)))
78 (:results (result :scs (any-reg descriptor-reg)))
79 (:temporary (:scs (non-descriptor-reg) :to (:result 0)) temp)
81 (:save-p :compute-only))
83 (define-vop (type-predicate)
84 (:args (value :scs (any-reg descriptor-reg)))
85 (:temporary (:scs (non-descriptor-reg)) temp)
90 (defun cost-to-test-types (type-codes)
91 (+ (* 2 (length type-codes))
92 (if (> (apply #'max type-codes) lowtag-limit) 7 2)))
94 (defmacro !define-type-vops (pred-name check-name ptype error-code
96 &key &allow-other-keys)
97 (let ((cost (cost-to-test-types (mapcar #'eval type-codes))))
100 `((define-vop (,pred-name type-predicate)
101 (:translate ,pred-name)
103 (test-type value target not-p (,@type-codes) :temp temp)))))
105 `((define-vop (,check-name check-type)
108 (generate-error-code vop ,error-code value)))
109 (test-type value err-lab t (,@type-codes) :temp temp)
110 (move value result))))))
112 `((primitive-type-vop ,check-name (:check) ,ptype))))))
114 ;;;; Other integer ranges.
116 ;;; A (signed-byte 32) can be represented with either fixnum or a bignum with
117 ;;; exactly one digit.
118 (defun signed-byte-32-test (value temp not-p target not-target)
122 (values not-target target)
123 (values target not-target))
125 (inst extru value 31 2 zero-tn :<>)
126 (inst b yep :nullify t)
127 (inst extru value 31 3 temp)
128 (inst bci :<> nil other-pointer-lowtag temp nope)
129 (loadw temp value 0 other-pointer-lowtag)
130 (inst bci := not-p (+ (ash 1 n-widetag-bits) bignum-widetag) temp target)))
133 (define-vop (signed-byte-32-p type-predicate)
134 (:translate signed-byte-32-p)
136 (signed-byte-32-test value temp not-p target not-target)
139 (define-vop (check-signed-byte-32 check-type)
141 (let ((loose (generate-error-code vop object-not-signed-byte-32-error
143 (signed-byte-32-test value temp t loose okay))
145 (move value result)))
147 ;;; An (unsigned-byte 32) can be represented with either a positive fixnum, a
148 ;;; bignum with exactly one positive digit, or a bignum with exactly two digits
149 ;;; and the second digit all zeros.
150 (defun unsigned-byte-32-test (value temp not-p target not-target)
151 (let ((nope (if not-p target not-target)))
154 (inst extru value 31 2 zero-tn :<>)
158 ;; If not, is it an other pointer?
159 (inst extru value 31 3 temp)
160 (inst bci :<> nil other-pointer-lowtag temp nope)
162 (loadw temp value 0 other-pointer-lowtag)
164 (inst bci := nil (+ (ash 1 n-widetag-bits) bignum-widetag) temp single-word)
165 ;; If it's other than two, we can't be an (unsigned-byte 32)
166 (inst bci :<> nil (+ (ash 2 n-widetag-bits) bignum-widetag) temp nope)
167 ;; Get the second digit.
168 (loadw temp value (1+ bignum-digits-offset) other-pointer-lowtag)
169 ;; All zeros, its an (unsigned-byte 32).
170 ;; Dont nullify comb here, because we cant guarantee target is forward
171 (inst comb (if not-p := :<>) temp zero-tn not-target)
176 ;; Get the single digit.
177 (loadw temp value bignum-digits-offset other-pointer-lowtag)
179 ;; positive implies (unsigned-byte 32).
181 (inst bc :>= not-p temp zero-tn target)))
184 (define-vop (unsigned-byte-32-p type-predicate)
185 (:translate unsigned-byte-32-p)
187 (unsigned-byte-32-test value temp not-p target not-target)
190 (define-vop (check-unsigned-byte-32 check-type)
192 (let ((loose (generate-error-code vop object-not-unsigned-byte-32-error
194 (unsigned-byte-32-test value temp t loose okay))
196 (move value result)))
199 ;;;; List/symbol types:
201 ;;; symbolp (or symbol (eq nil))
202 ;;; consp (and list (not (eq nil)))
204 (define-vop (symbolp type-predicate)
207 (inst bc := nil value null-tn (if not-p drop-thru target))
208 (test-type value target not-p (symbol-header-widetag) :temp temp)
211 (define-vop (check-symbol check-type)
213 (inst comb := value null-tn drop-thru)
214 (let ((error (generate-error-code vop object-not-symbol-error value)))
215 (test-type value error t (symbol-header-widetag) :temp temp))
217 (move value result)))
219 (define-vop (consp type-predicate)
222 (inst bc := nil value null-tn (if not-p target drop-thru))
223 (test-type value target not-p (list-pointer-lowtag) :temp temp)
226 (define-vop (check-cons check-type)
228 (let ((error (generate-error-code vop object-not-cons-error value)))
229 (inst bc := nil value null-tn error)
230 (test-type value error t (list-pointer-lowtag) :temp temp))
231 (move value result)))