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 ;;;; Other integer ranges.
76 ;;; A (signed-byte 32) can be represented with either fixnum or a bignum with
77 ;;; exactly one digit.
78 (defun signed-byte-32-test (value temp not-p target not-target
)
82 (values not-target target
)
83 (values target not-target
))
85 (inst extru value
31 2 zero-tn
:<>)
86 (inst b yep
:nullify t
)
87 (inst extru value
31 3 temp
)
88 (inst bci
:<> nil other-pointer-lowtag temp nope
)
89 (loadw temp value
0 other-pointer-lowtag
)
90 (inst bci
:= not-p
(+ (ash 1 n-widetag-bits
) bignum-widetag
) temp target
)))
93 (define-vop (signed-byte-32-p type-predicate
)
94 (:translate signed-byte-32-p
)
96 (signed-byte-32-test value temp not-p target not-target
)
99 ;;; An (unsigned-byte 32) can be represented with either a positive fixnum, a
100 ;;; bignum with exactly one positive digit, or a bignum with exactly two digits
101 ;;; and the second digit all zeros.
102 (defun unsigned-byte-32-test (value temp not-p target not-target
)
103 (let ((nope (if not-p target not-target
)))
106 (inst extru value
31 2 zero-tn
:<>)
110 ;; If not, is it an other pointer?
111 (inst extru value
31 3 temp
)
112 (inst bci
:<> nil other-pointer-lowtag temp nope
)
114 (loadw temp value
0 other-pointer-lowtag
)
116 (inst bci
:= nil
(+ (ash 1 n-widetag-bits
) bignum-widetag
) temp single-word
)
117 ;; If it's other than two, we can't be an (unsigned-byte 32)
118 (inst bci
:<> nil
(+ (ash 2 n-widetag-bits
) bignum-widetag
) temp nope
)
119 ;; Get the second digit.
120 (loadw temp value
(1+ bignum-digits-offset
) other-pointer-lowtag
)
121 ;; All zeros, its an (unsigned-byte 32).
122 ;; Dont nullify comb here, because we cant guarantee target is forward
123 (inst comb
(if not-p
:= :<>) temp zero-tn not-target
)
128 ;; Get the single digit.
129 (loadw temp value bignum-digits-offset other-pointer-lowtag
)
131 ;; positive implies (unsigned-byte 32).
133 (inst bc
:>= not-p temp zero-tn target
)))
136 (define-vop (unsigned-byte-32-p type-predicate
)
137 (:translate unsigned-byte-32-p
)
139 (unsigned-byte-32-test value temp not-p target not-target
)
142 ;;;; List/symbol types:
144 ;;; symbolp (or symbol (eq nil))
145 ;;; consp (and list (not (eq nil)))
147 (define-vop (symbolp type-predicate
)
150 (inst bc
:= nil value null-tn
(if not-p drop-thru target
))
151 (test-type value target not-p
(symbol-widetag) :temp temp
)
154 (define-vop (consp type-predicate
)
157 (inst bc
:= nil value null-tn
(if not-p target drop-thru
))
158 (test-type value target not-p
(list-pointer-lowtag) :temp temp
)