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)
25 "Set the Z flag if VALUE is fixnum"
27 (cond ((sc-is value any-reg descriptor-reg
)
28 (reg-in-size value
:byte
))
29 ;; This is hooey. None of the type-vops presently allow
30 ;; control-stack as a storage class.
31 ((sc-is value control-stack
)
32 (make-ea :byte
:base rbp-tn
33 :disp
(frame-byte-offset (tn-offset value
))))
38 (defun %test-fixnum
(value target not-p
)
39 (generate-fixnum-test value
)
40 (inst jmp
(if not-p
:nz
:z
) target
))
42 ;;; General FIXME: it's fine that we wire these to use rAX which has
43 ;;; the shortest encoding, but for goodness sake can we pass the TN
44 ;;; from the VOP like every other backend does? Freely referencing the
45 ;;; permanent globals RAX-TN,EAX-TN,AL-TN is a bad way to go about it.
47 (defun %lea-for-lowtag-test
(target value lowtag
)
48 (inst lea target
(make-ea :dword
:base value
:disp
(- lowtag
))))
50 ;; Numerics including fixnum, excluding short-float. (INTEGER,RATIONAL)
51 (defun %test-fixnum-and-headers
(value target not-p headers
)
52 (let ((drop-through (gen-label)))
53 (case n-fixnum-tag-bits
54 (1 (%lea-for-lowtag-test eax-tn value other-pointer-lowtag
)
56 (inst jmp
:nz
(if not-p drop-through target
)) ; inverted
57 (%test-headers value target not-p nil headers
58 :drop-through drop-through
:compute-eax nil
))
60 (generate-fixnum-test value
)
61 (inst jmp
:z
(if not-p drop-through target
))
62 (%test-headers value target not-p nil headers
63 :drop-through drop-through
)))))
65 ;; I can see no reason this would ever be used.
66 ;; (or fixnum character|unbound-marker) is implausible.
67 (defun %test-fixnum-and-immediate
(value target not-p immediate
)
68 (let ((drop-through (gen-label)))
69 (generate-fixnum-test value
)
70 (inst jmp
:z
(if not-p drop-through target
))
71 (%test-immediate value target not-p immediate drop-through
)))
74 (defun %test-fixnum-immediate-and-headers
(value target not-p immediate
76 (let ((drop-through (gen-label)))
77 (case n-fixnum-tag-bits
78 (1 (%lea-for-lowtag-test eax-tn value other-pointer-lowtag
)
80 (inst jmp
:nz
(if not-p drop-through target
)) ; inverted
81 (inst cmp al-tn
(- immediate other-pointer-lowtag
))
82 (inst jmp
:e
(if not-p drop-through target
))
83 (%test-headers value target not-p nil headers
84 :drop-through drop-through
:compute-eax nil
))
85 (t (generate-fixnum-test value
)
86 (inst jmp
:z
(if not-p drop-through target
))
87 (%test-immediate-and-headers value target not-p immediate headers
90 (defun %test-immediate
(value target not-p immediate
91 &optional
(drop-through (gen-label)))
92 ;; Code a single instruction byte test if possible.
93 (cond ((sc-is value any-reg descriptor-reg
)
94 (inst cmp
(reg-in-size value
:byte
) immediate
))
97 (inst cmp al-tn immediate
)))
98 (inst jmp
(if not-p
:ne
:e
) target
)
99 (emit-label drop-through
))
101 ;; Numerics including short-float, excluding fixnum
102 (defun %test-immediate-and-headers
(value target not-p immediate headers
103 &optional
(drop-through (gen-label)))
104 ;; Code a single instruction byte test if possible.
105 (cond ((sc-is value any-reg descriptor-reg
)
106 (inst cmp
(reg-in-size value
:byte
) immediate
))
109 (inst cmp al-tn immediate
)))
110 (inst jmp
:e
(if not-p drop-through target
))
111 (%test-headers value target not-p nil headers
:drop-through drop-through
))
113 (defun %test-lowtag
(value target not-p lowtag
)
114 (%lea-for-lowtag-test eax-tn value lowtag
)
115 (inst test al-tn lowtag-mask
)
116 (inst jmp
(if not-p
:nz
:z
) target
))
118 (defun %test-headers
(value target not-p function-p headers
120 (drop-through (gen-label))
122 (let ((lowtag (if function-p fun-pointer-lowtag other-pointer-lowtag
)))
123 (multiple-value-bind (equal less-or-equal greater-or-equal when-true
125 ;; EQUAL, LESS-OR-EQUAL, and GREATER-OR-EQUAL are the conditions
126 ;; for branching to TARGET. WHEN-TRUE and WHEN-FALSE are the
127 ;; labels to branch to when we know it's true and when we know
128 ;; it's false respectively.
130 (values :ne
:a
:b drop-through target
)
131 (values :e
:na
:nb target drop-through
))
133 (%lea-for-lowtag-test eax-tn value lowtag
))
134 (inst test al-tn lowtag-mask
)
135 (inst jmp
:nz when-false
)
136 ;; FIXME: this backend seems to be missing the special logic for
137 ;; testing exactly two widetags differing only in a single bit,
138 ;; which through evolution is almost totally unworkable anyway...
139 (do ((remaining headers
(cdr remaining
))
140 ;; It is preferable (smaller and faster code) to directly
141 ;; compare the value in memory instead of loading it into
142 ;; a register first. Find out if this is possible and set
143 ;; WIDETAG-TN accordingly. If impossible, generate the
145 ;; Compared to x86 we additionally optimize the cases of a
146 ;; range starting with BIGNUM-WIDETAG (= min widetag)
147 ;; or ending with COMPLEX-ARRAY-WIDETAG (= max widetag)
148 (widetag-tn (if (and (null (cdr headers
))
150 (or (atom (car headers
))
151 (= (caar headers
) bignum-widetag
)
152 (= (cdar headers
) complex-array-widetag
)))
153 (make-ea :byte
:base value
:disp
(- lowtag
))
155 (inst mov eax-tn
(make-ea :dword
:base value
159 (dolist (widetag except
) ; only after loading widetag-tn
160 (inst cmp al-tn widetag
)
161 (inst jmp
:e when-false
))
163 (let ((header (car remaining
))
164 (last (null (cdr remaining
))))
167 (inst cmp widetag-tn header
)
169 (inst jmp equal target
)
170 (inst jmp
:e when-true
)))
172 (let ((start (car header
))
175 ((= start bignum-widetag
)
176 (inst cmp widetag-tn end
)
178 (inst jmp less-or-equal target
)
179 (inst jmp
:be when-true
)))
180 ((= end complex-array-widetag
)
181 (inst cmp widetag-tn start
)
183 (inst jmp greater-or-equal target
)
184 (inst jmp
:b when-false
)))
186 (inst cmp al-tn start
)
187 (inst jmp
:b when-false
)
189 (inst jmp
:be when-true
))
191 (inst sub al-tn start
)
192 (inst cmp al-tn
(- end start
))
193 (inst jmp less-or-equal target
))))))))
194 (emit-label drop-through
))))
196 ;;;; other integer ranges
198 (define-vop (fixnump/unsigned-byte-64 simple-type-predicate
)
199 (:args
(value :scs
(unsigned-reg)))
200 (:arg-types unsigned-num
)
202 (:temporary
(:sc unsigned-reg
:from
(:argument
0)) tmp
)
207 (inst shr tmp n-positive-fixnum-bits
)))
209 #-
#.
(cl:if
(cl:= sb
!vm
:n-fixnum-tag-bits
1) '(:and
) '(:or
))
210 (define-vop (fixnump/signed-byte-64 simple-type-predicate
)
211 (:args
(value :scs
(signed-reg)))
214 (:temporary
(:sc unsigned-reg
) temp
)
215 (:arg-types signed-num
)
218 ;; Hackers Delight, p. 53: signed
219 ;; a <= x <= a + 2^n - 1
220 ;; is equivalent to unsigned
222 (inst mov temp
#.
(- sb
!xc
:most-negative-fixnum
))
223 (inst add temp value
)
224 (inst shr temp n-fixnum-bits
)))
226 #+#.
(cl:if
(cl:= sb
!vm
:n-fixnum-tag-bits
1) '(:and
) '(:or
))
227 (define-vop (fixnump/signed-byte-64 simple-type-predicate
)
228 (:args
(value :scs
(signed-reg) :target temp
))
231 (:temporary
(:sc unsigned-reg
:from
(:argument
0)) temp
)
232 (:arg-types signed-num
)
236 ;; The overflow flag will be set if the reg's sign bit changes.
239 ;;; A (SIGNED-BYTE 64) can be represented with either fixnum or a bignum with
240 ;;; exactly one digit.
242 (define-vop (signed-byte-64-p type-predicate
)
243 (:translate signed-byte-64-p
)
245 (multiple-value-bind (yep nope
)
247 (values not-target target
)
248 (values target not-target
))
249 #.
(case n-fixnum-tag-bits
251 (%lea-for-lowtag-test eax-tn value other-pointer-lowtag
)
252 (inst test al-tn fixnum-tag-mask
) ; 0th bit = 1 => fixnum
254 (inst test al-tn lowtag-mask
)))
256 (move-qword-to-eax value
)
257 (inst test al-tn fixnum-tag-mask
)
259 (inst and al-tn lowtag-mask
)
260 (inst cmp al-tn other-pointer-lowtag
))))
262 (inst cmp
(make-ea-for-object-slot value
0 other-pointer-lowtag
)
263 (+ (ash 1 n-widetag-bits
) bignum-widetag
))
264 (inst jmp
(if not-p
:ne
:e
) target
))
267 ;;; An (unsigned-byte 64) can be represented with either a positive
268 ;;; fixnum, a bignum with exactly one positive digit, or a bignum with
269 ;;; exactly two digits and the second digit all zeros.
270 (define-vop (unsigned-byte-64-p type-predicate
)
271 (:translate unsigned-byte-64-p
)
273 (let ((not-target (gen-label))
274 (single-word (gen-label))
275 (fixnum (gen-label)))
276 (multiple-value-bind (yep nope
)
278 (values not-target target
)
279 (values target not-target
))
282 (inst test al-tn fixnum-tag-mask
)
285 ;; If not, is it an other pointer?
286 (inst and al-tn lowtag-mask
)
287 (inst cmp al-tn other-pointer-lowtag
)
290 (loadw rax-tn value
0 other-pointer-lowtag
)
292 (inst cmp rax-tn
(+ (ash 1 n-widetag-bits
) bignum-widetag
))
293 (inst jmp
:e single-word
)
294 ;; If it's other than two, we can't be an (unsigned-byte 64)
295 ;: Leave RAX holding 0 in the affirmative case.
296 (inst sub rax-tn
(+ (ash 2 n-widetag-bits
) bignum-widetag
))
298 ;; Compare the second digit to zero (in RAX).
299 (inst cmp
(make-ea-for-object-slot value
(1+ bignum-digits-offset
)
300 other-pointer-lowtag
) rax-tn
)
301 (inst jmp
:z yep
) ; All zeros, its an (unsigned-byte 64).
304 (emit-label single-word
)
305 ;; Get the single digit.
306 (loadw rax-tn value bignum-digits-offset other-pointer-lowtag
)
308 ;; positive implies (unsigned-byte 64).
310 (inst test rax-tn rax-tn
)
311 (inst jmp
(if not-p
:s
:ns
) target
)
313 (emit-label not-target
)))))
315 (defun power-of-two-limit-p (x)
317 (= (logcount (1+ x
)) 1)))
319 (define-vop (test-fixnum-mod-power-of-two)
320 (:args
(value :scs
(any-reg descriptor-reg
321 unsigned-reg signed-reg
324 (:constant
(satisfies power-of-two-limit-p
)))
325 (:translate fixnum-mod-p
)
328 (:save-p
:compute-only
)
331 (aver (not (sc-is value immediate
)))
332 (let* ((fixnum-hi (if (sc-is value unsigned-reg signed-reg
)
335 (inst test value
(constantize (lognot fixnum-hi
))))))
337 (define-vop (test-fixnum-mod-tagged-unsigned)
338 (:args
(value :scs
(any-reg descriptor-reg
339 unsigned-reg signed-reg
341 (:arg-types
(:or tagged-num unsigned-num signed-num
)
343 (:translate fixnum-mod-p
)
346 (:save-p
:compute-only
)
349 (aver (not (sc-is value immediate
)))
350 (let ((fixnum-hi (if (sc-is value unsigned-reg signed-reg
)
353 (inst cmp value
(constantize fixnum-hi
)))))
355 (define-vop (test-fixnum-mod-*)
356 (:args
(value :scs
(any-reg descriptor-reg
)))
357 (:arg-types
* (:constant fixnum
))
358 (:translate fixnum-mod-p
)
360 (:info target not-p hi
)
361 (:save-p
:compute-only
)
364 (let* ((fixnum-hi (fixnumize hi
))
366 (generate-fixnum-test value
)
367 (inst jmp
:ne
(if not-p target skip
))
368 (inst cmp value
(constantize fixnum-hi
))
369 (inst jmp
(if not-p
:a
:be
) target
)
372 ;;;; list/symbol types
374 ;;; symbolp (or symbol (eq nil))
375 ;;; consp (and list (not (eq nil)))
377 (define-vop (symbolp type-predicate
)
380 (let ((is-symbol-label (if not-p DROP-THRU target
)))
381 (inst cmp value nil-value
)
382 (inst jmp
:e is-symbol-label
)
383 (test-type value target not-p
(symbol-header-widetag)))
386 (define-vop (consp type-predicate
)
389 (let ((is-not-cons-label (if not-p target DROP-THRU
)))
390 (inst cmp value nil-value
)
391 (inst jmp
:e is-not-cons-label
)
392 (test-type value target not-p
(list-pointer-lowtag)))
395 ;; A vop that accepts a computed set of widetags.
396 (define-vop (%other-pointer-subtype-p type-predicate
)
397 (:translate %other-pointer-subtype-p
)
398 (:info target not-p widetags
)
399 (:arg-types
* (:constant t
)) ; voodoo - 'target' and 'not-p' are absent
400 (:generator
15 ; arbitrary
401 (multiple-value-bind (headers exceptions
)
402 (canonicalize-widetags+exceptions widetags
)
403 (%test-headers value target not-p nil headers
404 :except exceptions
))))