1 ;;;; type testing and checking VOPs for the x86 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 make-byte-tn (tn)
17 (aver (sc-is tn any-reg descriptor-reg unsigned-reg signed-reg
))
18 (make-random-tn :kind
:normal
19 :sc
(sc-or-lose 'byte-reg
)
20 :offset
(tn-offset tn
)))
22 (defun generate-fixnum-test (value)
23 "zero flag set if VALUE is fixnum"
24 (let ((offset (tn-offset value
)))
25 ;; The x86 backend uses a pun from E[A-D]X -> [A-D]L for these
26 ;; tests. The Athlon 64 optimization guide says that this is a
27 ;; bad idea, so it's been removed.
28 (cond ((sc-is value control-stack
)
29 (inst test
(make-ea :byte
:base rbp-tn
30 :disp
(- (* (1+ offset
) n-word-bytes
)))
31 sb
!vm
::fixnum-tag-mask
))
33 (inst test value sb
!vm
::fixnum-tag-mask
)))))
35 (defun %test-fixnum
(value target not-p
)
36 (generate-fixnum-test value
)
37 (inst jmp
(if not-p
:nz
:z
) target
))
39 (defun %test-fixnum-and-headers
(value target not-p headers
)
40 (let ((drop-through (gen-label)))
41 (generate-fixnum-test value
)
42 (inst jmp
:z
(if not-p drop-through target
))
43 (%test-headers value target not-p nil headers drop-through
)))
45 (defun %test-fixnum-and-immediate
(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 value target not-p immediate drop-through
)))
51 (defun %test-fixnum-immediate-and-headers
(value target not-p immediate
53 (let ((drop-through (gen-label)))
54 (generate-fixnum-test value
)
55 (inst jmp
:z
(if not-p drop-through target
))
56 (%test-immediate-and-headers value target not-p immediate headers
59 (defun %test-immediate
(value target not-p immediate
60 &optional
(drop-through (gen-label)))
61 ;; Code a single instruction byte test if possible.
62 (cond ((sc-is value any-reg descriptor-reg
)
63 (inst cmp
(make-byte-tn value
) immediate
))
66 (inst cmp al-tn immediate
)))
67 (inst jmp
(if not-p
:ne
:e
) target
)
68 (emit-label drop-through
))
70 (defun %test-immediate-and-headers
(value target not-p immediate headers
71 &optional
(drop-through (gen-label)))
72 ;; Code a single instruction byte test if possible.
73 (cond ((sc-is value any-reg descriptor-reg
)
74 (inst cmp
(make-byte-tn value
) immediate
))
77 (inst cmp al-tn immediate
)))
78 (inst jmp
:e
(if not-p drop-through target
))
79 (%test-headers value target not-p nil headers drop-through
))
81 (defun %test-lowtag
(value target not-p lowtag
)
83 (inst and rax-tn lowtag-mask
)
84 (inst cmp rax-tn lowtag
)
85 (inst jmp
(if not-p
:ne
:e
) target
))
87 (defun %test-headers
(value target not-p function-p headers
88 &optional
(drop-through (gen-label)))
89 (let ((lowtag (if function-p fun-pointer-lowtag other-pointer-lowtag
)))
90 (multiple-value-bind (equal less-or-equal when-true when-false
)
91 ;; EQUAL and LESS-OR-EQUAL are the conditions for branching to TARGET.
92 ;; WHEN-TRUE and WHEN-FALSE are the labels to branch to when we know
93 ;; it's true and when we know it's false respectively.
95 (values :ne
:a drop-through target
)
96 (values :e
:na target drop-through
))
97 (%test-lowtag value when-false t lowtag
)
98 (inst mov al-tn
(make-ea :byte
:base value
:disp
(- lowtag
)))
99 (do ((remaining headers
(cdr remaining
)))
101 (let ((header (car remaining
))
102 (last (null (cdr remaining
))))
105 (inst cmp al-tn header
)
107 (inst jmp equal target
)
108 (inst jmp
:e when-true
)))
110 (let ((start (car header
))
112 (unless (= start bignum-widetag
)
113 (inst cmp al-tn start
)
114 (inst jmp
:b when-false
)) ; was :l
117 (inst jmp less-or-equal target
)
118 (inst jmp
:be when-true
))))))) ; was :le
119 (emit-label drop-through
))))
122 ;;;; type checking and testing
124 (define-vop (check-type)
125 (:args
(value :target result
:scs
(any-reg descriptor-reg
)))
126 (:results
(result :scs
(any-reg descriptor-reg
)))
127 (:temporary
(:sc unsigned-reg
:offset eax-offset
:to
(:result
0)) eax
)
130 (:save-p
:compute-only
))
132 (define-vop (type-predicate)
133 (:args
(value :scs
(any-reg descriptor-reg
)))
134 (:temporary
(:sc unsigned-reg
:offset eax-offset
) eax
)
138 (:policy
:fast-safe
))
140 ;;; simpler VOP that don't need a temporary register
141 (define-vop (simple-check-type)
142 (:args
(value :target result
:scs
(any-reg descriptor-reg
)))
143 (:results
(result :scs
(any-reg descriptor-reg
)
144 :load-if
(not (and (sc-is value any-reg descriptor-reg
)
145 (sc-is result control-stack
)))))
147 (:save-p
:compute-only
))
149 (define-vop (simple-type-predicate)
150 (:args
(value :scs
(any-reg descriptor-reg control-stack
)))
153 (:policy
:fast-safe
))
155 (defun cost-to-test-types (type-codes)
156 (+ (* 2 (length type-codes
))
157 (if (> (apply #'max type-codes
) lowtag-limit
) 7 2)))
159 (defmacro !define-type-vops
(pred-name check-name ptype error-code
161 &key
(variant nil variant-p
) &allow-other-keys
)
162 ;; KLUDGE: UGH. Why do we need this eval? Can't we put this in the
164 (let* ((cost (cost-to-test-types (mapcar #'eval type-codes
)))
165 (prefix (if variant-p
166 (concatenate 'string
(string variant
) "-")
170 `((define-vop (,pred-name
,(intern (concatenate 'string prefix
"TYPE-PREDICATE")))
171 (:translate
,pred-name
)
173 (test-type value target not-p
(,@type-codes
))))))
175 `((define-vop (,check-name
,(intern (concatenate 'string prefix
"CHECK-TYPE")))
178 (generate-error-code vop
,error-code value
)))
179 (test-type value err-lab t
(,@type-codes
))
180 (move result value
))))))
182 `((primitive-type-vop ,check-name
(:check
) ,ptype
))))))
184 ;;;; other integer ranges
186 (define-vop (fixnump/unsigned-byte-64 simple-type-predicate
)
187 (:args
(value :scs
(unsigned-reg)))
188 (:arg-types unsigned-num
)
190 (:temporary
(:sc unsigned-reg
) tmp
)
193 (inst shr tmp n-positive-fixnum-bits
)
194 (inst jmp
(if not-p
:nz
:z
) target
)))
196 ;;; A (SIGNED-BYTE 64) can be represented with either fixnum or a bignum with
197 ;;; exactly one digit.
199 (define-vop (signed-byte-64-p type-predicate
)
200 (:translate signed-byte-64-p
)
202 (multiple-value-bind (yep nope
)
204 (values not-target target
)
205 (values target not-target
))
206 (generate-fixnum-test value
)
209 (inst and al-tn lowtag-mask
)
210 (inst cmp al-tn other-pointer-lowtag
)
212 (loadw rax-tn value
0 other-pointer-lowtag
)
213 (inst cmp rax-tn
(+ (ash 1 n-widetag-bits
) bignum-widetag
))
214 (inst jmp
(if not-p
:ne
:e
) target
))
217 (define-vop (check-signed-byte-64 check-type
)
219 (let ((nope (generate-error-code vop
220 object-not-signed-byte-64-error
222 (generate-fixnum-test value
)
225 (inst and al-tn lowtag-mask
)
226 (inst cmp al-tn other-pointer-lowtag
)
228 (loadw rax-tn value
0 other-pointer-lowtag
)
229 (inst cmp rax-tn
(+ (ash 1 n-widetag-bits
) bignum-widetag
))
232 (move result value
)))
234 ;;; An (unsigned-byte 64) can be represented with either a positive
235 ;;; fixnum, a bignum with exactly one positive digit, or a bignum with
236 ;;; exactly two digits and the second digit all zeros.
237 (define-vop (unsigned-byte-64-p type-predicate
)
238 (:translate unsigned-byte-64-p
)
240 (let ((not-target (gen-label))
241 (single-word (gen-label))
242 (fixnum (gen-label)))
243 (multiple-value-bind (yep nope
)
245 (values not-target target
)
246 (values target not-target
))
248 (generate-fixnum-test value
)
252 ;; If not, is it an other pointer?
253 (inst and rax-tn lowtag-mask
)
254 (inst cmp rax-tn other-pointer-lowtag
)
257 (loadw rax-tn value
0 other-pointer-lowtag
)
259 (inst cmp rax-tn
(+ (ash 1 n-widetag-bits
) bignum-widetag
))
260 (inst jmp
:e single-word
)
261 ;; If it's other than two, we can't be an (unsigned-byte 64)
262 (inst cmp rax-tn
(+ (ash 2 n-widetag-bits
) bignum-widetag
))
264 ;; Get the second digit.
265 (loadw rax-tn value
(1+ bignum-digits-offset
) other-pointer-lowtag
)
266 ;; All zeros, its an (unsigned-byte 64).
267 (inst or rax-tn rax-tn
)
271 (emit-label single-word
)
272 ;; Get the single digit.
273 (loadw rax-tn value bignum-digits-offset other-pointer-lowtag
)
275 ;; positive implies (unsigned-byte 64).
277 (inst or rax-tn rax-tn
)
278 (inst jmp
(if not-p
:s
:ns
) target
)
280 (emit-label not-target
)))))
282 (define-vop (check-unsigned-byte-64 check-type
)
285 (generate-error-code vop object-not-unsigned-byte-64-error value
))
288 (single-word (gen-label)))
291 (generate-fixnum-test value
)
295 ;; If not, is it an other pointer?
296 (inst and rax-tn lowtag-mask
)
297 (inst cmp rax-tn other-pointer-lowtag
)
300 (loadw rax-tn value
0 other-pointer-lowtag
)
302 (inst cmp rax-tn
(+ (ash 1 n-widetag-bits
) bignum-widetag
))
303 (inst jmp
:e single-word
)
304 ;; If it's other than two, we can't be an (unsigned-byte 64)
305 (inst cmp rax-tn
(+ (ash 2 n-widetag-bits
) bignum-widetag
))
307 ;; Get the second digit.
308 (loadw rax-tn value
(1+ bignum-digits-offset
) other-pointer-lowtag
)
309 ;; All zeros, its an (unsigned-byte 64).
310 (inst or rax-tn rax-tn
)
314 (emit-label single-word
)
315 ;; Get the single digit.
316 (loadw rax-tn value bignum-digits-offset other-pointer-lowtag
)
318 ;; positive implies (unsigned-byte 64).
320 (inst or rax-tn rax-tn
)
324 (move result value
))))
326 ;;;; list/symbol types
328 ;;; symbolp (or symbol (eq nil))
329 ;;; consp (and list (not (eq nil)))
331 (define-vop (symbolp type-predicate
)
334 (let ((is-symbol-label (if not-p DROP-THRU target
)))
335 (inst cmp value nil-value
)
336 (inst jmp
:e is-symbol-label
)
337 (test-type value target not-p
(symbol-header-widetag)))
340 (define-vop (check-symbol check-type
)
342 (let ((error (generate-error-code vop object-not-symbol-error value
)))
343 (inst cmp value nil-value
)
344 (inst jmp
:e DROP-THRU
)
345 (test-type value error t
(symbol-header-widetag)))
347 (move result value
)))
349 (define-vop (consp type-predicate
)
352 (let ((is-not-cons-label (if not-p target DROP-THRU
)))
353 (inst cmp value nil-value
)
354 (inst jmp
:e is-not-cons-label
)
355 (test-type value target not-p
(list-pointer-lowtag)))
358 (define-vop (check-cons check-type
)
360 (let ((error (generate-error-code vop object-not-cons-error value
)))
361 (inst cmp value nil-value
)
363 (test-type value error t
(list-pointer-lowtag))
364 (move result value
))))