1 ;;;; type testing and checking VOPs for the x86-64 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
16 ;;; Optimize the case of moving a 64-bit value into RAX when not caring
17 ;;; about the upper 32 bits: often the REX prefix can be spared.
18 (defun move-qword-to-eax (value)
19 (if (and (sc-is value any-reg descriptor-reg
)
20 (< (tn-offset value
) r8-offset
))
21 (move eax-tn
(reg-in-size value
:dword
))
24 (defun generate-fixnum-test (value)
26 "Set the Z flag if VALUE is fixnum"
28 (cond ((sc-is value any-reg descriptor-reg
)
29 (reg-in-size value
:byte
))
30 ;; This is hooey. None of the type-vops presently allow
31 ;; control-stack as a storage class.
32 ((sc-is value control-stack
)
33 (make-ea :byte
:base rbp-tn
34 :disp
(frame-byte-offset (tn-offset value
))))
39 (defun %test-fixnum
(value target not-p
)
40 (generate-fixnum-test value
)
41 (inst jmp
(if not-p
:nz
:z
) target
))
43 ;;; General FIXME: it's fine that we wire these to use rAX which has
44 ;;; the shortest encoding, but for goodness sake can we pass the TN
45 ;;; from the VOP like every other backend does? Freely referencing the
46 ;;; permanent globals RAX-TN,EAX-TN,AL-TN is a bad way to go about it.
48 (defun %lea-for-lowtag-test
(target value lowtag
)
49 (inst lea target
(make-ea :dword
:base value
:disp
(- lowtag
))))
51 ;; Numerics including fixnum, excluding short-float. (INTEGER,RATIONAL)
52 (defun %test-fixnum-and-headers
(value target not-p headers
)
53 (let ((drop-through (gen-label)))
54 (case n-fixnum-tag-bits
55 (1 (%lea-for-lowtag-test eax-tn value other-pointer-lowtag
)
57 (inst jmp
:nz
(if not-p drop-through target
)) ; inverted
58 (%test-headers value target not-p nil headers
59 :drop-through drop-through
:compute-eax nil
))
61 (generate-fixnum-test value
)
62 (inst jmp
:z
(if not-p drop-through target
))
63 (%test-headers value target not-p nil headers
64 :drop-through drop-through
)))))
66 ;; I can see no reason this would ever be used.
67 ;; (or fixnum character|unbound-marker) is implausible.
68 (defun %test-fixnum-and-immediate
(value target not-p immediate
)
69 (let ((drop-through (gen-label)))
70 (generate-fixnum-test value
)
71 (inst jmp
:z
(if not-p drop-through target
))
72 (%test-immediate value target not-p immediate drop-through
)))
75 (defun %test-fixnum-immediate-and-headers
(value target not-p immediate
77 (let ((drop-through (gen-label)))
78 (case n-fixnum-tag-bits
79 (1 (%lea-for-lowtag-test eax-tn value other-pointer-lowtag
)
81 (inst jmp
:nz
(if not-p drop-through target
)) ; inverted
82 (inst cmp al-tn
(- immediate other-pointer-lowtag
))
83 (inst jmp
:e
(if not-p drop-through target
))
84 (%test-headers value target not-p nil headers
85 :drop-through drop-through
:compute-eax nil
))
86 (t (generate-fixnum-test value
)
87 (inst jmp
:z
(if not-p drop-through target
))
88 (%test-immediate-and-headers value target not-p immediate headers
91 (defun %test-immediate
(value target not-p immediate
92 &optional
(drop-through (gen-label)))
93 ;; Code a single instruction byte test if possible.
94 (cond ((sc-is value any-reg descriptor-reg
)
95 (inst cmp
(reg-in-size value
:byte
) immediate
))
98 (inst cmp al-tn immediate
)))
99 (inst jmp
(if not-p
:ne
:e
) target
)
100 (emit-label drop-through
))
102 ;; Numerics including short-float, excluding fixnum
103 (defun %test-immediate-and-headers
(value target not-p immediate headers
104 &optional
(drop-through (gen-label)))
105 ;; Code a single instruction byte test if possible.
106 (cond ((sc-is value any-reg descriptor-reg
)
107 (inst cmp
(reg-in-size value
:byte
) immediate
))
110 (inst cmp al-tn immediate
)))
111 (inst jmp
:e
(if not-p drop-through target
))
112 (%test-headers value target not-p nil headers
:drop-through drop-through
))
114 (defun %test-lowtag
(value target not-p lowtag
)
115 (%lea-for-lowtag-test eax-tn value lowtag
)
116 (inst test al-tn lowtag-mask
)
117 (inst jmp
(if not-p
:nz
:z
) target
))
119 (defun %test-headers
(value target not-p function-p headers
121 (drop-through (gen-label))
123 (let ((lowtag (if function-p fun-pointer-lowtag other-pointer-lowtag
)))
124 (multiple-value-bind (equal less-or-equal greater-or-equal when-true
126 ;; EQUAL, LESS-OR-EQUAL, and GREATER-OR-EQUAL are the conditions
127 ;; for branching to TARGET. WHEN-TRUE and WHEN-FALSE are the
128 ;; labels to branch to when we know it's true and when we know
129 ;; it's false respectively.
131 (values :ne
:a
:b drop-through target
)
132 (values :e
:na
:nb target drop-through
))
134 (%lea-for-lowtag-test eax-tn value lowtag
))
135 (inst test al-tn lowtag-mask
)
136 (inst jmp
:nz when-false
)
137 ;; FIXME: this backend seems to be missing the special logic for
138 ;; testing exactly two widetags differing only in a single bit,
139 ;; which through evolution is almost totally unworkable anyway...
140 (do ((remaining headers
(cdr remaining
))
141 ;; It is preferable (smaller and faster code) to directly
142 ;; compare the value in memory instead of loading it into
143 ;; a register first. Find out if this is possible and set
144 ;; WIDETAG-TN accordingly. If impossible, generate the
146 ;; Compared to x86 we additionally optimize the cases of a
147 ;; range starting with BIGNUM-WIDETAG (= min widetag)
148 ;; or ending with COMPLEX-ARRAY-WIDETAG (= max widetag)
149 (widetag-tn (if (and (null (cdr headers
))
151 (or (atom (car headers
))
152 (= (caar headers
) bignum-widetag
)
153 (= (cdar headers
) complex-array-widetag
)))
154 (make-ea :byte
:base value
:disp
(- lowtag
))
156 (inst mov eax-tn
(make-ea :dword
:base value
160 (dolist (widetag except
) ; only after loading widetag-tn
161 (inst cmp al-tn widetag
)
162 (inst jmp
:e when-false
))
164 (let ((header (car remaining
))
165 (last (null (cdr remaining
))))
168 (inst cmp widetag-tn header
)
170 (inst jmp equal target
)
171 (inst jmp
:e when-true
)))
173 (let ((start (car header
))
176 ((= start bignum-widetag
)
177 (inst cmp widetag-tn end
)
179 (inst jmp less-or-equal target
)
180 (inst jmp
:be when-true
)))
181 ((= end complex-array-widetag
)
182 (inst cmp widetag-tn start
)
184 (inst jmp greater-or-equal target
)
185 (inst jmp
:b when-false
)))
187 (inst cmp al-tn start
)
188 (inst jmp
:b when-false
)
190 (inst jmp
:be when-true
))
192 (inst sub al-tn start
)
193 (inst cmp al-tn
(- end start
))
194 (inst jmp less-or-equal target
))))))))
195 (emit-label drop-through
))))
197 ;;;; other integer ranges
199 (define-vop (fixnump/unsigned-byte-64 simple-type-predicate
)
200 (:args
(value :scs
(unsigned-reg)))
201 (:arg-types unsigned-num
)
203 (:temporary
(:sc unsigned-reg
:from
(:argument
0)) tmp
)
208 (inst shr tmp n-positive-fixnum-bits
)))
210 #-
#.
(cl:if
(cl:= sb
!vm
:n-fixnum-tag-bits
1) '(:and
) '(:or
))
211 (define-vop (fixnump/signed-byte-64 simple-type-predicate
)
212 (:args
(value :scs
(signed-reg)))
215 (:temporary
(:sc unsigned-reg
) temp
)
216 (:arg-types signed-num
)
219 ;; Hackers Delight, p. 53: signed
220 ;; a <= x <= a + 2^n - 1
221 ;; is equivalent to unsigned
223 (inst mov temp
#.
(- sb
!xc
:most-negative-fixnum
))
224 (inst add temp value
)
225 (inst shr temp n-fixnum-bits
)))
227 #+#.
(cl:if
(cl:= sb
!vm
:n-fixnum-tag-bits
1) '(:and
) '(:or
))
228 (define-vop (fixnump/signed-byte-64 simple-type-predicate
)
229 (:args
(value :scs
(signed-reg) :target temp
))
232 (:temporary
(:sc unsigned-reg
:from
(:argument
0)) temp
)
233 (:arg-types signed-num
)
237 ;; The overflow flag will be set if the reg's sign bit changes.
240 ;;; A (SIGNED-BYTE 64) can be represented with either fixnum or a bignum with
241 ;;; exactly one digit.
243 (define-vop (signed-byte-64-p type-predicate
)
244 (:translate signed-byte-64-p
)
246 (multiple-value-bind (yep nope
)
248 (values not-target target
)
249 (values target not-target
))
250 #.
(case n-fixnum-tag-bits
252 (%lea-for-lowtag-test eax-tn value other-pointer-lowtag
)
253 (inst test al-tn fixnum-tag-mask
) ; 0th bit = 1 => fixnum
255 (inst test al-tn lowtag-mask
)))
257 (move-qword-to-eax value
)
258 (inst test al-tn fixnum-tag-mask
)
260 (inst and al-tn lowtag-mask
)
261 (inst cmp al-tn other-pointer-lowtag
))))
263 (inst cmp
(make-ea-for-object-slot value
0 other-pointer-lowtag
)
264 (+ (ash 1 n-widetag-bits
) bignum-widetag
))
265 (inst jmp
(if not-p
:ne
:e
) target
))
268 ;;; An (unsigned-byte 64) can be represented with either a positive
269 ;;; fixnum, a bignum with exactly one positive digit, or a bignum with
270 ;;; exactly two digits and the second digit all zeros.
271 (define-vop (unsigned-byte-64-p type-predicate
)
272 (:translate unsigned-byte-64-p
)
274 (let ((not-target (gen-label))
275 (single-word (gen-label))
276 (fixnum (gen-label)))
277 (multiple-value-bind (yep nope
)
279 (values not-target target
)
280 (values target not-target
))
283 (inst test al-tn fixnum-tag-mask
)
286 ;; If not, is it an other pointer?
287 (inst and al-tn lowtag-mask
)
288 (inst cmp al-tn other-pointer-lowtag
)
291 (loadw rax-tn value
0 other-pointer-lowtag
)
293 (inst cmp rax-tn
(+ (ash 1 n-widetag-bits
) bignum-widetag
))
294 (inst jmp
:e single-word
)
295 ;; If it's other than two, we can't be an (unsigned-byte 64)
296 ;: Leave RAX holding 0 in the affirmative case.
297 (inst sub rax-tn
(+ (ash 2 n-widetag-bits
) bignum-widetag
))
299 ;; Compare the second digit to zero (in RAX).
300 (inst cmp
(make-ea-for-object-slot value
(1+ bignum-digits-offset
)
301 other-pointer-lowtag
) rax-tn
)
302 (inst jmp
:z yep
) ; All zeros, its an (unsigned-byte 64).
305 (emit-label single-word
)
306 ;; Get the single digit.
307 (loadw rax-tn value bignum-digits-offset other-pointer-lowtag
)
309 ;; positive implies (unsigned-byte 64).
311 (inst test rax-tn rax-tn
)
312 (inst jmp
(if not-p
:s
:ns
) target
)
314 (emit-label not-target
)))))
316 (defun power-of-two-limit-p (x)
318 (= (logcount (1+ x
)) 1)))
320 (define-vop (test-fixnum-mod-power-of-two)
321 (:args
(value :scs
(any-reg descriptor-reg
322 unsigned-reg signed-reg
325 (:constant
(satisfies power-of-two-limit-p
)))
326 (:translate fixnum-mod-p
)
329 (:save-p
:compute-only
)
332 (aver (not (sc-is value immediate
)))
333 (let* ((fixnum-hi (if (sc-is value unsigned-reg signed-reg
)
336 (inst test value
(constantize (lognot fixnum-hi
))))))
338 (define-vop (test-fixnum-mod-tagged-unsigned)
339 (:args
(value :scs
(any-reg descriptor-reg
340 unsigned-reg signed-reg
342 (:arg-types
(:or tagged-num unsigned-num signed-num
)
344 (:translate fixnum-mod-p
)
347 (:save-p
:compute-only
)
350 (aver (not (sc-is value immediate
)))
351 (let ((fixnum-hi (if (sc-is value unsigned-reg signed-reg
)
354 (inst cmp value
(constantize fixnum-hi
)))))
356 (define-vop (test-fixnum-mod-*)
357 (:args
(value :scs
(any-reg descriptor-reg
)))
358 (:arg-types
* (:constant fixnum
))
359 (:translate fixnum-mod-p
)
361 (:info target not-p hi
)
362 (:save-p
:compute-only
)
365 (let* ((fixnum-hi (fixnumize hi
))
367 (generate-fixnum-test value
)
368 (inst jmp
:ne
(if not-p target skip
))
369 (inst cmp value
(constantize fixnum-hi
))
370 (inst jmp
(if not-p
:a
:be
) target
)
373 ;;;; list/symbol types
375 ;;; symbolp (or symbol (eq nil))
376 ;;; consp (and list (not (eq nil)))
378 (define-vop (symbolp type-predicate
)
381 (let ((is-symbol-label (if not-p DROP-THRU target
)))
382 (inst cmp value nil-value
)
383 (inst jmp
:e is-symbol-label
)
384 (test-type value target not-p
(symbol-header-widetag)))
387 (define-vop (consp type-predicate
)
390 (let ((is-not-cons-label (if not-p target DROP-THRU
)))
391 (inst cmp value nil-value
)
392 (inst jmp
:e is-not-cons-label
)
393 (test-type value target not-p
(list-pointer-lowtag)))
396 ;; A vop that accepts a computed set of widetags.
397 (define-vop (%other-pointer-subtype-p type-predicate
)
398 (:translate %other-pointer-subtype-p
)
399 (:info target not-p widetags
)
400 (:arg-types
* (:constant t
)) ; voodoo - 'target' and 'not-p' are absent
401 (:generator
15 ; arbitrary
402 (multiple-value-bind (headers exceptions
)
403 (canonicalize-headers-and-exceptions widetags
)
404 (%test-headers value target not-p nil headers
405 :except exceptions
))))