cf5de08ce88b67682fe0f3b148c4679195fc5be7
[sbcl.git] / src / compiler / hppa / type-vops.lisp
1 ;;;; type testing and checking VOPs for the HPPA VM
2
3 ;;;; This software is part of the SBCL system. See the README file for
4 ;;;; more information.
5 ;;;;
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.
11
12 (in-package "SB!VM")
13 \f
14 ;;; Test generation utilities.
15 (defun %test-fixnum (value target not-p &key temp)
16   (declare (ignore temp))
17   (assemble ()
18     (inst extru value 31 2 zero-tn (if not-p := :<>))
19     (inst b target :nullify t)))
20
21 (defun %test-fixnum-and-headers (value target not-p headers &key temp)
22   (let ((drop-through (gen-label)))
23     (assemble ()
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)))
28
29 (defun %test-immediate (value target not-p immediate &key temp)
30   (assemble ()
31     (inst extru value 31 8 temp)
32     (inst bci := not-p immediate temp target)))
33
34 (defun %test-lowtag (value target not-p lowtag
35                      &key temp temp-loaded)
36   (assemble ()
37     (unless temp-loaded
38       (inst extru value 31 3 temp))
39     (inst bci := not-p lowtag temp target)))
40
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
45                   :temp temp)
46     (%test-headers value target not-p function-p headers
47                    :drop-through drop-through :temp temp :temp-loaded t)))
48
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)))
52     (multiple-value-bind
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.
57         (if not-p
58             (values :<> :< drop-through target)
59             (values := :>= target drop-through))
60       (assemble ()
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)))
65             ((null remaining))
66           (let ((header (car remaining))
67                 (last (null (cdr remaining))))
68             (cond
69              ((atom header)
70               (if last
71                   (inst bci equal nil header temp target)
72                   (inst bci := nil header temp when-true)))
73              (t
74               (let ((start (car header))
75                     (end (cdr header)))
76                 (unless (= start bignum-widetag)
77                   (inst bci :> nil start temp when-false))
78                 (if last
79                     (inst bci greater-or-equal nil end temp target)
80                     (inst bci :>= nil end temp when-true)))))))
81         (emit-label drop-through)))))
82 \f
83 ;;;; Type checking and testing:
84
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)
89   (:vop-var vop)
90   (:save-p :compute-only))
91
92 (define-vop (type-predicate)
93   (:args (value :scs (any-reg descriptor-reg)))
94   (:temporary (:scs (non-descriptor-reg)) temp)
95   (:conditional)
96   (:info target not-p)
97   (:policy :fast-safe))
98
99 (defun cost-to-test-types (type-codes)
100   (+ (* 2 (length type-codes))
101      (if (> (apply #'max type-codes) lowtag-limit) 7 2)))
102
103 (defmacro !define-type-vops (pred-name check-name ptype error-code
104                              (&rest type-codes)
105                              &key &allow-other-keys)
106   (let ((cost (cost-to-test-types (mapcar #'eval type-codes))))
107     `(progn
108        ,@(when pred-name
109            `((define-vop (,pred-name type-predicate)
110                (:translate ,pred-name)
111                (:generator ,cost
112                  (test-type value target not-p (,@type-codes) :temp temp)))))
113        ,@(when check-name
114            `((define-vop (,check-name check-type)
115                (:generator ,cost
116                  (let ((err-lab
117                         (generate-error-code vop ,error-code value)))
118                    (test-type value err-lab t (,@type-codes) :temp temp)
119                    (move value result))))))
120        ,@(when ptype
121            `((primitive-type-vop ,check-name (:check) ,ptype))))))
122 \f
123 ;;;; Other integer ranges.
124
125 ;;; A (signed-byte 32) can be represented with either fixnum or a bignum with
126 ;;; exactly one digit.
127
128 (defun signed-byte-32-test (value temp not-p target not-target)
129   (multiple-value-bind
130       (yep nope)
131       (if not-p
132           (values not-target target)
133           (values target not-target))
134     (assemble ()
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)))
141   (values))
142
143 (define-vop (signed-byte-32-p type-predicate)
144   (:translate signed-byte-32-p)
145   (:generator 45
146     (signed-byte-32-test value temp not-p target not-target)
147     NOT-TARGET))
148
149 (define-vop (check-signed-byte-32 check-type)
150   (:generator 45
151     (let ((loose (generate-error-code vop object-not-signed-byte-32-error
152                                       value)))
153       (signed-byte-32-test value temp t loose okay))
154     OKAY
155     (move value result)))
156
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.
160
161 (defun unsigned-byte-32-test (value temp not-p target not-target)
162   (let ((nope (if not-p target not-target)))
163     (assemble ()
164       ;; Is it a fixnum?
165       (inst extru value 31 2 zero-tn :<>)
166       (inst b fixnum)
167       (inst move value temp)
168
169       ;; If not, is it an other pointer?
170       (inst extru value 31 3 temp)
171       (inst bci :<> nil other-pointer-lowtag temp nope)
172       ;; Get the header.
173       (loadw temp value 0 other-pointer-lowtag)
174       ;; Is it one?
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)
183         
184       SINGLE-WORD
185       ;; Get the single digit.
186       (loadw temp value bignum-digits-offset other-pointer-lowtag)
187
188       ;; positive implies (unsigned-byte 32).
189       FIXNUM
190       (inst bc :>= not-p temp zero-tn target)))
191   (values))
192
193 (define-vop (unsigned-byte-32-p type-predicate)
194   (:translate unsigned-byte-32-p)
195   (:generator 45
196     (unsigned-byte-32-test value temp not-p target not-target)
197     NOT-TARGET))
198
199 (define-vop (check-unsigned-byte-32 check-type)
200   (:generator 45
201     (let ((loose (generate-error-code vop object-not-unsigned-byte-32-error
202                                       value)))
203       (unsigned-byte-32-test value temp t loose okay))
204     OKAY
205     (move value result)))
206
207 \f
208 ;;;; List/symbol types:
209 ;;; 
210 ;;; symbolp (or symbol (eq nil))
211 ;;; consp (and list (not (eq nil)))
212
213 (define-vop (symbolp type-predicate)
214   (:translate symbolp)
215   (:generator 12
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)
218     DROP-THRU))
219
220 (define-vop (check-symbol check-type)
221   (:generator 12
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))
225     DROP-THRU
226     (move value result)))
227   
228 (define-vop (consp type-predicate)
229   (:translate consp)
230   (:generator 8
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)
233     DROP-THRU))
234
235 (define-vop (check-cons check-type)
236   (:generator 8
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)))
241