1;;;; type testing and checking VOPs for the x86 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
14;;;; test generation utilities
15
16(defun generate-fixnum-test (value)
17  (emit-optimized-test-inst value fixnum-tag-mask))
18
19(defun %test-fixnum (value target not-p)
20  (generate-fixnum-test value)
21  (inst jmp (if not-p :nz :z) target))
22
23(defun %test-fixnum-and-headers (value target not-p headers)
24  (let ((drop-through (gen-label)))
25    (generate-fixnum-test value)
26    (inst jmp :z (if not-p drop-through target))
27    (%test-headers value target not-p nil headers :drop-through drop-through)))
28
29(defun %test-immediate (value target not-p immediate)
30  ;; Code a single instruction byte test if possible.
31  (let ((offset (tn-offset value)))
32    (cond ((and (sc-is value any-reg descriptor-reg)
33                (or (= offset eax-offset) (= offset ebx-offset)
34                    (= offset ecx-offset) (= offset edx-offset)))
35           (inst cmp (make-random-tn :kind :normal
36                                     :sc (sc-or-lose 'byte-reg)
37                                     :offset offset)
38                 immediate))
39          (t
40           (move eax-tn value)
41           (inst cmp al-tn immediate))))
42  (inst jmp (if not-p :ne :e) target))
43
44(defun %test-lowtag (value target not-p lowtag)
45  (inst lea eax-tn (make-ea :dword :base value :disp (- lowtag)))
46  (inst test al-tn lowtag-mask)
47  ;; FIXME: another 'optimization' which doesn't appear to work:
48  ;; prefetching the hypothetically pointed-to version should help,
49  ;; but this is in fact non-ideal in plenty of ways: we emit way too
50  ;; many of these prefetch instructions; pointed-to objects are very
51  ;; often in the cache anyway; etc. etc.  Still, as proof-of-concept,
52  ;; not too bad.  -- CSR, 2004-07-27
53  (when (member :prefetch *backend-subfeatures*)
54    (inst prefetchnta (make-ea :byte :base value :disp (- lowtag))))
55  (inst jmp (if not-p :ne :e) target))
56
57(defun %test-headers (value target not-p function-p headers
58                            &key except (drop-through (gen-label)))
59  (let ((lowtag (if function-p fun-pointer-lowtag other-pointer-lowtag)))
60    (multiple-value-bind (equal less-or-equal greater-or-equal when-true when-false)
61        ;; EQUAL, LESS-OR-EQUAL and GREATER-OR-EQUAL are the conditions for
62        ;; branching to TARGET.  WHEN-TRUE and WHEN-FALSE are the
63        ;; labels to branch to when we know it's true and when we know
64        ;; it's false respectively.
65        (if not-p
66            (values :ne :a :b drop-through target)
67            (values :e :na :nb target drop-through))
68      (%test-lowtag value when-false t lowtag)
69      (cond
70        ((and (null (cdr headers))
71              (not except)
72              (numberp (car headers)))
73         ;; Optimize the common case: referencing the value from memory
74         ;; is slightly smaller than loading it and then doing the
75         ;; comparison.  Doing this for other cases (e.g. range of
76         ;; [BIGNUM-WIDETAG..FOO-WIDETAG]) is also possible, but such
77         ;; opportunities don't come up very often and the code would
78         ;; get pretty hairy...
79         (inst cmp (make-ea :byte :base value :disp (- lowtag)) (car headers))
80         (inst jmp equal target))
81        (t
82         (inst mov al-tn (make-ea :byte :base value :disp (- lowtag)))
83         (dolist (widetag except)
84           (inst cmp al-tn widetag)
85           (inst jmp :e when-false))
86         (do ((remaining headers (cdr remaining)))
87             ((null remaining))
88           (let ((header (car remaining))
89                 (last (null (cdr remaining))))
90             (cond
91               ((atom header)
92                (cond
93                  ((and (not last) (null (cddr remaining))
94                        (atom (cadr remaining))
95                        (= (logcount (logxor header (cadr remaining))) 1))
96                   ;; FIXME: (VECTOR T) does not and could not admit this hack.
97                   ;; The others could but are broken except for BIT-VECTOR.
98                   ;; BASE-STRING, (VECTOR NIL), BIT-VECTOR, (VECTOR T)
99                   (inst and al-tn (ldb (byte 8 0) (logeqv header (cadr remaining))))
100                   (inst cmp al-tn (ldb (byte 8 0) (logand header (cadr remaining))))
101                   (inst jmp equal target)
102                   (return))
103                  (t
104                   (inst cmp al-tn header)
105                   (if last
106                       (inst jmp equal target)
107                       (inst jmp :e when-true)))))
108               (t
109                (let ((start (car header))
110                      (end (cdr header)))
111                  (cond
112                    ;; LAST = don't need al-tn later
113                    ((and last (not (= start bignum-widetag))
114                          (= (+ start 4) end) (= (logcount (logxor start end)) 1))
115                     ;; SIMPLE-STRING
116                     (inst and al-tn (ldb (byte 8 0) (logeqv start end)))
117                     (inst cmp al-tn (ldb (byte 8 0) (logand start end)))
118                     (inst jmp equal target))
119                    ((and (not last) (null (cddr remaining))
120                          (= (+ start 4) end) (= (logcount (logxor start end)) 1)
121                          (listp (cadr remaining))
122                          (= (+ (caadr remaining) 4) (cdadr remaining))
123                          (= (logcount (logxor (caadr remaining) (cdadr remaining))) 1)
124                          (= (logcount (logxor (caadr remaining) start)) 1))
125                     ;; STRING
126                     (inst and al-tn (ldb (byte 8 0) (logeqv start (cdadr remaining))))
127                     (inst cmp al-tn (ldb (byte 8 0) (logand start (cdadr remaining))))
128                     (inst jmp equal target)
129                     ;; we've shortcircuited the DO, so we must return.
130                     ;; It's OK to do so, because (NULL (CDDR REMAINING))
131                     ;; was true.
132                     (return))
133                    (t
134                     (cond
135                       ((= start bignum-widetag)
136                        (inst cmp al-tn end)
137                        (if last
138                            (inst jmp less-or-equal target)
139                            (inst jmp :be when-true)))
140                       ((= end complex-array-widetag)
141                        (inst cmp al-tn start)
142                        (if last
143                            (inst jmp greater-or-equal target)
144                            (inst jmp :b when-false)))
145                       ((not last)
146                        (inst cmp al-tn start)
147                        (inst jmp :b when-false)
148                        (inst cmp al-tn end)
149                        (if last
150                            (inst jmp less-or-equal target)
151                            (inst jmp :be when-true)))
152                       (t
153                        (inst sub al-tn start)
154                        (inst cmp al-tn (- end start))
155                        (inst jmp less-or-equal target))))))))))))
156      (emit-label drop-through))))
157
158;;; simpler VOP that don't need a temporary register
159(define-vop (simple-type-predicate)
160  (:args (value :scs (any-reg descriptor-reg control-stack)))
161  (:conditional)
162  (:info target not-p)
163  (:policy :fast-safe))
164
165;;;; other integer ranges
166
167(define-vop (fixnump/unsigned-byte-32 simple-type-predicate)
168  (:args (value :scs (unsigned-reg)))
169  (:info)
170  (:conditional :be)
171  (:arg-types unsigned-num)
172  (:translate fixnump)
173  (:generator 5
174    ;; We could encode this with :Z and SHR, analogously to the signed-byte-32
175    ;; case below -- as we do on x86-64 -- but that costs us an extra
176    ;; register. Compromises...
177    (inst cmp value #.sb!xc:most-positive-fixnum)))
178
179(define-vop (fixnump/signed-byte-32 type-predicate)
180  (:args (value :scs (signed-reg)))
181  (:info)
182  (:conditional :z)
183  (:arg-types signed-num)
184  (:translate fixnump)
185  (:generator 5
186    ;; Hackers Delight, p. 53: signed
187    ;;    a <= x <= a + 2^n - 1
188    ;; is equivalent to unsigned
189    ;;    ((x-a) >> n) = 0
190    (inst mov eax-tn value)
191    (inst sub eax-tn #.sb!xc:most-negative-fixnum)
192    (inst shr eax-tn #.(integer-length (- sb!xc:most-positive-fixnum
193                                          sb!xc:most-negative-fixnum)))))
194
195;;; A (SIGNED-BYTE 32) can be represented with either fixnum or a bignum with
196;;; exactly one digit.
197
198(define-vop (signed-byte-32-p type-predicate)
199  (:translate signed-byte-32-p)
200  (:generator 45
201    (multiple-value-bind (yep nope)
202        (if not-p
203            (values not-target target)
204            (values target not-target))
205      (generate-fixnum-test value)
206      (inst jmp :e yep)
207      (inst lea eax-tn (make-ea :dword :base value
208                                :disp (- other-pointer-lowtag)))
209      (inst test al-tn lowtag-mask)
210      (inst jmp :ne nope)
211      (inst cmp (make-ea-for-object-slot value 0 other-pointer-lowtag)
212            (+ (ash 1 n-widetag-bits) bignum-widetag))
213      (inst jmp (if not-p :ne :e) target))
214    NOT-TARGET))
215
216;;; An (unsigned-byte 32) can be represented with either a positive
217;;; fixnum, a bignum with exactly one positive digit, or a bignum with
218;;; exactly two digits and the second digit all zeros.
219(define-vop (unsigned-byte-32-p type-predicate)
220  (:translate unsigned-byte-32-p)
221  (:generator 45
222    (let ((not-target (gen-label))
223          (single-word (gen-label))
224          (fixnum (gen-label)))
225      (multiple-value-bind (yep nope)
226          (if not-p
227              (values not-target target)
228              (values target not-target))
229        ;; Is it a fixnum?
230        (move eax-tn value)
231        (inst test al-tn fixnum-tag-mask)
232        (inst jmp :e fixnum)
233
234        ;; If not, is it an other pointer?
235        (inst and al-tn lowtag-mask)
236        (inst cmp al-tn other-pointer-lowtag)
237        (inst jmp :ne nope)
238        ;; Get the header.
239        (loadw eax-tn value 0 other-pointer-lowtag)
240        ;; Is it one?
241        (inst cmp eax-tn (+ (ash 1 n-widetag-bits) bignum-widetag))
242        (inst jmp :e single-word)
243        ;; If it's other than two, we can't be an (unsigned-byte 32)
244        ;: Leave EAX holding 0 in the affirmative case.
245        (inst sub eax-tn (+ (ash 2 n-widetag-bits) bignum-widetag))
246        (inst jmp :ne nope)
247        ;; Compare the second digit to zero (in EAX).
248        (inst cmp (make-ea-for-object-slot value (1+ bignum-digits-offset)
249                                           other-pointer-lowtag) eax-tn)
250        (inst jmp :z yep) ; All zeros, its an (unsigned-byte 32).
251        (inst jmp nope)
252
253        (emit-label single-word)
254        ;; Get the single digit.
255        (loadw eax-tn value bignum-digits-offset other-pointer-lowtag)
256
257        ;; positive implies (unsigned-byte 32).
258        (emit-label fixnum)
259        (inst test eax-tn eax-tn)
260        (inst jmp (if not-p :s :ns) target)
261
262        (emit-label not-target)))))
263
264(defun power-of-two-limit-p (x)
265  (and (fixnump x)
266       (= (logcount (1+ x)) 1)))
267
268(define-vop (test-fixnum-mod-power-of-two)
269  (:args (value :scs (any-reg descriptor-reg
270                              unsigned-reg signed-reg
271                              immediate)))
272  (:arg-types *
273              (:constant (satisfies power-of-two-limit-p)))
274  (:translate sb!c::fixnum-mod-p)
275  (:conditional :e)
276  (:info hi)
277  (:save-p :compute-only)
278  (:policy :fast-safe)
279  (:generator 4
280     (aver (not (sc-is value immediate)))
281     (let* ((fixnum-hi (if (sc-is value unsigned-reg signed-reg)
282                           hi
283                           (fixnumize hi))))
284       (inst test value (lognot fixnum-hi)))))
285
286(define-vop (test-fixnum-mod-tagged-unsigned)
287  (:args (value :scs (any-reg descriptor-reg
288                              unsigned-reg signed-reg
289                              immediate)))
290  (:arg-types (:or tagged-num unsigned-num signed-num)
291              (:constant fixnum))
292  (:translate sb!c::fixnum-mod-p)
293  (:conditional :be)
294  (:info hi)
295  (:save-p :compute-only)
296  (:policy :fast-safe)
297  (:generator 5
298     (aver (not (sc-is value immediate)))
299     (let ((fixnum-hi (if (sc-is value unsigned-reg signed-reg)
300                          hi
301                          (fixnumize hi))))
302       (inst cmp value fixnum-hi))))
303
304(define-vop (test-fixnum-mod-*)
305  (:args (value :scs (any-reg descriptor-reg)))
306  (:arg-types * (:constant fixnum))
307  (:translate sb!c::fixnum-mod-p)
308  (:conditional)
309  (:info target not-p hi)
310  (:save-p :compute-only)
311  (:policy :fast-safe)
312  (:generator 6
313     (let* ((fixnum-hi (fixnumize hi))
314            (skip (gen-label)))
315       (generate-fixnum-test value)
316       (inst jmp :ne (if not-p target skip))
317       (inst cmp value fixnum-hi)
318       (inst jmp (if not-p :a :be) target)
319       (emit-label skip))))
320
321
322;;;; list/symbol types
323;;;
324;;; symbolp (or symbol (eq nil))
325;;; consp (and list (not (eq nil)))
326
327(define-vop (symbolp type-predicate)
328  (:translate symbolp)
329  (:generator 12
330    (let ((is-symbol-label (if not-p DROP-THRU target))
331          (widetag-tn (make-ea :byte :base value :disp (- other-pointer-lowtag))))
332      ;; It could have been done with just TEST-TYPE, but using CMP on
333      ;; EAX saves one byte, this basically unrolls TEST-TYPE and
334      ;; inserts a comparison to NIL in the middle.
335      (inst lea eax-tn widetag-tn)
336      (inst cmp eax-tn (- nil-value other-pointer-lowtag))
337      (inst jmp :e is-symbol-label)
338      (inst test al-tn other-pointer-lowtag)
339      (inst jmp :nz (if not-p target drop-thru))
340      (inst cmp widetag-tn symbol-header-widetag)
341      (inst jmp (if not-p :ne :e) target))
342    DROP-THRU))
343
344(define-vop (consp type-predicate)
345  (:translate consp)
346  (:generator 8
347     (let ((is-not-cons-label (if not-p target drop-thru)))
348       ;; It could have been done with just TEST-TYPE, but using CMP on
349       ;; EAX saves one byte, this basically unrolls TEST-TYPE and
350       ;; inserts a comparison to NIL in the middle.
351       (inst lea eax-tn (make-ea :dword :base value :disp (- list-pointer-lowtag)))
352       (inst cmp eax-tn (- nil-value list-pointer-lowtag))
353       (inst jmp :e is-not-cons-label)
354       (inst test al-tn other-pointer-lowtag)
355       (inst jmp (if not-p :nz :z) target))
356    DROP-THRU))
357
358;; A vop that accepts a computed set of widetags.
359(define-vop (%other-pointer-subtype-p type-predicate)
360  (:translate %other-pointer-subtype-p)
361  (:info target not-p widetags)
362  (:arg-types * (:constant t)) ; voodoo - 'target' and 'not-p' are absent
363  (:generator 15 ; arbitrary
364    (multiple-value-bind (headers exceptions)
365        (canonicalize-widetags+exceptions widetags)
366      (%test-headers value target not-p nil headers
367                     :except exceptions))))
368