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 (defun generate-fixnum-test (value)
17 "zero flag set if VALUE is fixnum"
19 (cond ((sc-is value any-reg descriptor-reg
)
21 ((sc-is value control-stack
)
22 (make-ea :byte
:base rbp-tn
23 :disp
(- (* (1+ (tn-offset value
)) n-word-bytes
))))
26 sb
!vm
::fixnum-tag-mask
))
28 (defun %test-fixnum
(value target not-p
)
29 (generate-fixnum-test value
)
30 (inst jmp
(if not-p
:nz
:z
) target
))
32 (defun %test-fixnum-and-headers
(value target not-p headers
)
33 (let ((drop-through (gen-label)))
34 (generate-fixnum-test value
)
35 (inst jmp
:z
(if not-p drop-through target
))
36 (%test-headers value target not-p nil headers drop-through
)))
38 (defun %test-fixnum-and-immediate
(value target not-p immediate
)
39 (let ((drop-through (gen-label)))
40 (generate-fixnum-test value
)
41 (inst jmp
:z
(if not-p drop-through target
))
42 (%test-immediate value target not-p immediate drop-through
)))
44 (defun %test-fixnum-immediate-and-headers
(value target not-p immediate
46 (let ((drop-through (gen-label)))
47 (generate-fixnum-test value
)
48 (inst jmp
:z
(if not-p drop-through target
))
49 (%test-immediate-and-headers value target not-p immediate headers
52 (defun %test-immediate
(value target not-p immediate
53 &optional
(drop-through (gen-label)))
54 ;; Code a single instruction byte test if possible.
55 (cond ((sc-is value any-reg descriptor-reg
)
56 (inst cmp
(make-byte-tn value
) immediate
))
59 (inst cmp al-tn immediate
)))
60 (inst jmp
(if not-p
:ne
:e
) target
)
61 (emit-label drop-through
))
63 (defun %test-immediate-and-headers
(value target not-p immediate headers
64 &optional
(drop-through (gen-label)))
65 ;; Code a single instruction byte test if possible.
66 (cond ((sc-is value any-reg descriptor-reg
)
67 (inst cmp
(make-byte-tn value
) immediate
))
70 (inst cmp al-tn immediate
)))
71 (inst jmp
:e
(if not-p drop-through target
))
72 (%test-headers value target not-p nil headers drop-through
))
74 (defun %test-lowtag
(value target not-p lowtag
)
75 (if (and (sc-is value any-reg descriptor-reg
)
76 (< (tn-offset value
) r8-offset
))
77 (move eax-tn
(make-dword-tn value
)) ; shorter encoding (no REX prefix)
79 (inst and al-tn lowtag-mask
)
80 (inst cmp al-tn lowtag
)
81 (inst jmp
(if not-p
:ne
:e
) target
))
83 (defun %test-headers
(value target not-p function-p headers
84 &optional
(drop-through (gen-label)))
85 (let ((lowtag (if function-p fun-pointer-lowtag other-pointer-lowtag
)))
86 (multiple-value-bind (equal less-or-equal when-true when-false
)
87 ;; EQUAL and LESS-OR-EQUAL are the conditions for branching to TARGET.
88 ;; WHEN-TRUE and WHEN-FALSE are the labels to branch to when we know
89 ;; it's true and when we know it's false respectively.
91 (values :ne
:a drop-through target
)
92 (values :e
:na target drop-through
))
93 (%test-lowtag value when-false t lowtag
)
94 (inst mov al-tn
(make-ea :byte
:base value
:disp
(- lowtag
)))
95 (do ((remaining headers
(cdr remaining
)))
97 (let ((header (car remaining
))
98 (last (null (cdr remaining
))))
101 (inst cmp al-tn header
)
103 (inst jmp equal target
)
104 (inst jmp
:e when-true
)))
106 (let ((start (car header
))
108 (unless (= start bignum-widetag
)
109 (inst cmp al-tn start
)
110 (inst jmp
:b when-false
)) ; was :l
113 (inst jmp less-or-equal target
)
114 (inst jmp
:be when-true
))))))) ; was :le
115 (emit-label drop-through
))))
118 ;;;; type checking and testing
120 (define-vop (check-type)
121 (:args
(value :target result
:scs
(any-reg descriptor-reg
)))
122 (:results
(result :scs
(any-reg descriptor-reg
)))
123 (:temporary
(:sc unsigned-reg
:offset eax-offset
:to
(:result
0)) eax
)
126 (:save-p
:compute-only
))
128 (define-vop (type-predicate)
129 (:args
(value :scs
(any-reg descriptor-reg
)))
130 (:temporary
(:sc unsigned-reg
:offset eax-offset
) eax
)
134 (:policy
:fast-safe
))
136 ;;; simpler VOP that don't need a temporary register
137 (define-vop (simple-check-type)
138 (:args
(value :target result
:scs
(any-reg descriptor-reg
)))
139 (:results
(result :scs
(any-reg descriptor-reg
)
140 :load-if
(not (and (sc-is value any-reg descriptor-reg
)
141 (sc-is result control-stack
)))))
143 (:save-p
:compute-only
))
145 (define-vop (simple-type-predicate)
146 (:args
(value :scs
(any-reg descriptor-reg control-stack
)))
149 (:policy
:fast-safe
))
151 (defun cost-to-test-types (type-codes)
152 (+ (* 2 (length type-codes
))
153 (if (> (apply #'max type-codes
) lowtag-limit
) 7 2)))
155 (defmacro !define-type-vops
(pred-name check-name ptype error-code
157 &key
(variant nil variant-p
) &allow-other-keys
)
158 ;; KLUDGE: UGH. Why do we need this eval? Can't we put this in the
160 (let* ((cost (cost-to-test-types (mapcar #'eval type-codes
)))
161 (prefix (if variant-p
162 (concatenate 'string
(string variant
) "-")
166 `((define-vop (,pred-name
,(intern (concatenate 'string prefix
"TYPE-PREDICATE")))
167 (:translate
,pred-name
)
169 (test-type value target not-p
(,@type-codes
))))))
171 `((define-vop (,check-name
,(intern (concatenate 'string prefix
"CHECK-TYPE")))
174 (generate-error-code vop
,error-code value
)))
175 (test-type value err-lab t
(,@type-codes
))
176 (move result value
))))))
178 `((primitive-type-vop ,check-name
(:check
) ,ptype
))))))
180 ;;;; other integer ranges
182 (define-vop (fixnump/unsigned-byte-64 simple-type-predicate
)
183 (:args
(value :scs
(unsigned-reg)))
184 (:arg-types unsigned-num
)
186 (:temporary
(:sc unsigned-reg
) tmp
)
189 (inst shr tmp n-positive-fixnum-bits
)
190 (inst jmp
(if not-p
:nz
:z
) target
)))
192 ;;; A (SIGNED-BYTE 64) can be represented with either fixnum or a bignum with
193 ;;; exactly one digit.
195 (define-vop (signed-byte-64-p type-predicate
)
196 (:translate signed-byte-64-p
)
198 (multiple-value-bind (yep nope
)
200 (values not-target target
)
201 (values target not-target
))
202 (generate-fixnum-test value
)
205 (inst and al-tn lowtag-mask
)
206 (inst cmp al-tn other-pointer-lowtag
)
208 (loadw rax-tn value
0 other-pointer-lowtag
)
209 (inst cmp rax-tn
(+ (ash 1 n-widetag-bits
) bignum-widetag
))
210 (inst jmp
(if not-p
:ne
:e
) target
))
213 (define-vop (check-signed-byte-64 check-type
)
215 (let ((nope (generate-error-code vop
216 object-not-signed-byte-64-error
218 (generate-fixnum-test value
)
221 (inst and al-tn lowtag-mask
)
222 (inst cmp al-tn other-pointer-lowtag
)
224 (loadw rax-tn value
0 other-pointer-lowtag
)
225 (inst cmp rax-tn
(+ (ash 1 n-widetag-bits
) bignum-widetag
))
228 (move result value
)))
230 ;;; An (unsigned-byte 64) can be represented with either a positive
231 ;;; fixnum, a bignum with exactly one positive digit, or a bignum with
232 ;;; exactly two digits and the second digit all zeros.
233 (define-vop (unsigned-byte-64-p type-predicate
)
234 (:translate unsigned-byte-64-p
)
236 (let ((not-target (gen-label))
237 (single-word (gen-label))
238 (fixnum (gen-label)))
239 (multiple-value-bind (yep nope
)
241 (values not-target target
)
242 (values target not-target
))
244 (generate-fixnum-test value
)
248 ;; If not, is it an other pointer?
249 (inst and rax-tn lowtag-mask
)
250 (inst cmp rax-tn other-pointer-lowtag
)
253 (loadw rax-tn value
0 other-pointer-lowtag
)
255 (inst cmp rax-tn
(+ (ash 1 n-widetag-bits
) bignum-widetag
))
256 (inst jmp
:e single-word
)
257 ;; If it's other than two, we can't be an (unsigned-byte 64)
258 (inst cmp rax-tn
(+ (ash 2 n-widetag-bits
) bignum-widetag
))
260 ;; Get the second digit.
261 (loadw rax-tn value
(1+ bignum-digits-offset
) other-pointer-lowtag
)
262 ;; All zeros, its an (unsigned-byte 64).
263 (inst or rax-tn rax-tn
)
267 (emit-label single-word
)
268 ;; Get the single digit.
269 (loadw rax-tn value bignum-digits-offset other-pointer-lowtag
)
271 ;; positive implies (unsigned-byte 64).
273 (inst or rax-tn rax-tn
)
274 (inst jmp
(if not-p
:s
:ns
) target
)
276 (emit-label not-target
)))))
278 (define-vop (check-unsigned-byte-64 check-type
)
281 (generate-error-code vop object-not-unsigned-byte-64-error value
))
284 (single-word (gen-label)))
287 (generate-fixnum-test value
)
291 ;; If not, is it an other pointer?
292 (inst and rax-tn lowtag-mask
)
293 (inst cmp rax-tn other-pointer-lowtag
)
296 (loadw rax-tn value
0 other-pointer-lowtag
)
298 (inst cmp rax-tn
(+ (ash 1 n-widetag-bits
) bignum-widetag
))
299 (inst jmp
:e single-word
)
300 ;; If it's other than two, we can't be an (unsigned-byte 64)
301 (inst cmp rax-tn
(+ (ash 2 n-widetag-bits
) bignum-widetag
))
303 ;; Get the second digit.
304 (loadw rax-tn value
(1+ bignum-digits-offset
) other-pointer-lowtag
)
305 ;; All zeros, its an (unsigned-byte 64).
306 (inst or rax-tn rax-tn
)
310 (emit-label single-word
)
311 ;; Get the single digit.
312 (loadw rax-tn value bignum-digits-offset other-pointer-lowtag
)
314 ;; positive implies (unsigned-byte 64).
316 (inst or rax-tn rax-tn
)
320 (move result value
))))
322 ;;;; list/symbol types
324 ;;; symbolp (or symbol (eq nil))
325 ;;; consp (and list (not (eq nil)))
327 (define-vop (symbolp type-predicate
)
330 (let ((is-symbol-label (if not-p DROP-THRU target
)))
331 (inst cmp value nil-value
)
332 (inst jmp
:e is-symbol-label
)
333 (test-type value target not-p
(symbol-header-widetag)))
336 (define-vop (check-symbol check-type
)
338 (let ((error (generate-error-code vop object-not-symbol-error value
)))
339 (inst cmp value nil-value
)
340 (inst jmp
:e DROP-THRU
)
341 (test-type value error t
(symbol-header-widetag)))
343 (move result value
)))
345 (define-vop (consp type-predicate
)
348 (let ((is-not-cons-label (if not-p target DROP-THRU
)))
349 (inst cmp value nil-value
)
350 (inst jmp
:e is-not-cons-label
)
351 (test-type value target not-p
(list-pointer-lowtag)))
354 (define-vop (check-cons check-type
)
356 (let ((error (generate-error-code vop object-not-cons-error value
)))
357 (inst cmp value nil-value
)
359 (test-type value error t
(list-pointer-lowtag))
360 (move result value
))))