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 (make-dword-tn value))
24 (defun generate-fixnum-test (value)
25 "zero flag set if VALUE is fixnum"
27 (cond ((sc-is value any-reg descriptor-reg)
29 ((sc-is value control-stack)
30 (make-ea :byte :base rbp-tn
31 :disp (frame-byte-offset (tn-offset value))))
34 sb!vm::fixnum-tag-mask))
36 (defun %test-fixnum (value target not-p)
37 (generate-fixnum-test value)
38 (inst jmp (if not-p :nz :z) target))
40 (defun %test-fixnum-and-headers (value target not-p headers)
41 (let ((drop-through (gen-label)))
42 (generate-fixnum-test value)
43 (inst jmp :z (if not-p drop-through target))
44 (%test-headers value target not-p nil headers drop-through)))
46 (defun %test-fixnum-and-immediate (value target not-p immediate)
47 (let ((drop-through (gen-label)))
48 (generate-fixnum-test value)
49 (inst jmp :z (if not-p drop-through target))
50 (%test-immediate value target not-p immediate drop-through)))
52 (defun %test-fixnum-immediate-and-headers (value target not-p immediate
54 (let ((drop-through (gen-label)))
55 (generate-fixnum-test value)
56 (inst jmp :z (if not-p drop-through target))
57 (%test-immediate-and-headers value target not-p immediate headers
60 (defun %test-immediate (value target not-p immediate
61 &optional (drop-through (gen-label)))
62 ;; Code a single instruction byte test if possible.
63 (cond ((sc-is value any-reg descriptor-reg)
64 (inst cmp (make-byte-tn value) immediate))
67 (inst cmp al-tn immediate)))
68 (inst jmp (if not-p :ne :e) target)
69 (emit-label drop-through))
71 (defun %test-immediate-and-headers (value target not-p immediate headers
72 &optional (drop-through (gen-label)))
73 ;; Code a single instruction byte test if possible.
74 (cond ((sc-is value any-reg descriptor-reg)
75 (inst cmp (make-byte-tn value) immediate))
78 (inst cmp al-tn immediate)))
79 (inst jmp :e (if not-p drop-through target))
80 (%test-headers value target not-p nil headers drop-through))
82 (defun %test-lowtag (value target not-p lowtag)
83 (move-qword-to-eax value)
84 (inst and al-tn lowtag-mask)
85 (inst cmp al-tn lowtag)
86 (inst jmp (if not-p :ne :e) target))
88 (defun %test-headers (value target not-p function-p headers
89 &optional (drop-through (gen-label)))
90 (let ((lowtag (if function-p fun-pointer-lowtag other-pointer-lowtag)))
91 (multiple-value-bind (equal less-or-equal greater-or-equal when-true
93 ;; EQUAL, LESS-OR-EQUAL, and GREATER-OR-EQUAL are the conditions
94 ;; for branching to TARGET. WHEN-TRUE and WHEN-FALSE are the
95 ;; labels to branch to when we know it's true and when we know
96 ;; it's false respectively.
98 (values :ne :a :b drop-through target)
99 (values :e :na :nb target drop-through))
100 (%test-lowtag value when-false t lowtag)
101 (do ((remaining headers (cdr remaining))
102 ;; It is preferable (smaller and faster code) to directly
103 ;; compare the value in memory instead of loading it into
104 ;; a register first. Find out if this is possible and set
105 ;; WIDETAG-TN accordingly. If impossible, generate the
107 ;; Compared to x86 we additionally optimize the cases of a
108 ;; range starting with BIGNUM-WIDETAG or ending with
109 ;; COMPLEX-ARRAY-WIDETAG.
110 (widetag-tn (if (and (null (cdr headers))
111 (or (atom (car headers))
112 (= (caar headers) bignum-widetag)
113 (= (cdar headers) complex-array-widetag)))
114 (make-ea :byte :base value :disp (- lowtag))
116 (inst mov eax-tn (make-ea :dword :base value
120 (let ((header (car remaining))
121 (last (null (cdr remaining))))
124 (inst cmp widetag-tn header)
126 (inst jmp equal target)
127 (inst jmp :e when-true)))
129 (let ((start (car header))
132 ((= start bignum-widetag)
133 (inst cmp widetag-tn end)
135 (inst jmp less-or-equal target)
136 (inst jmp :be when-true)))
137 ((= end complex-array-widetag)
138 (inst cmp widetag-tn start)
140 (inst jmp greater-or-equal target)
141 (inst jmp :b when-false)))
143 (inst cmp al-tn start)
144 (inst jmp :b when-false)
146 (inst jmp :be when-true))
148 (inst sub al-tn start)
149 (inst cmp al-tn (- end start))
150 (inst jmp less-or-equal target))))))))
151 (emit-label drop-through))))
154 ;;;; type checking and testing
156 (define-vop (check-type)
157 (:args (value :target result :scs (any-reg descriptor-reg)))
158 (:results (result :scs (any-reg descriptor-reg)))
159 (:temporary (:sc unsigned-reg :offset eax-offset :to (:result 0)) eax)
162 (:save-p :compute-only))
164 (define-vop (type-predicate)
165 (:args (value :scs (any-reg descriptor-reg)))
166 (:temporary (:sc unsigned-reg :offset eax-offset) eax)
170 (:policy :fast-safe))
172 ;;; simpler VOP that don't need a temporary register
173 (define-vop (simple-check-type)
174 (:args (value :target result :scs (any-reg descriptor-reg)))
175 (:results (result :scs (any-reg descriptor-reg)
176 :load-if (not (and (sc-is value any-reg descriptor-reg)
177 (sc-is result control-stack)))))
179 (:save-p :compute-only))
181 (define-vop (simple-type-predicate)
182 (:args (value :scs (any-reg descriptor-reg control-stack)))
185 (:policy :fast-safe))
187 (defun cost-to-test-types (type-codes)
188 (+ (* 2 (length type-codes))
189 (if (> (apply #'max type-codes) lowtag-limit) 7 2)))
191 (defmacro !define-type-vops (pred-name check-name ptype error-code
193 &key (variant nil variant-p) &allow-other-keys)
194 ;; KLUDGE: UGH. Why do we need this eval? Can't we put this in the
196 (let* ((cost (cost-to-test-types (mapcar #'eval type-codes)))
197 (prefix (if variant-p
198 (concatenate 'string (string variant) "-")
202 `((define-vop (,pred-name ,(intern (concatenate 'string prefix "TYPE-PREDICATE")))
203 (:translate ,pred-name)
205 (test-type value target not-p (,@type-codes))))))
207 `((define-vop (,check-name ,(intern (concatenate 'string prefix "CHECK-TYPE")))
210 (generate-error-code vop ',error-code value)))
211 (test-type value err-lab t (,@type-codes))
212 (move result value))))))
214 `((primitive-type-vop ,check-name (:check) ,ptype))))))
216 ;;;; other integer ranges
218 (define-vop (fixnump/unsigned-byte-64 simple-type-predicate)
219 (:args (value :scs (unsigned-reg)))
220 (:arg-types unsigned-num)
222 (:temporary (:sc unsigned-reg) tmp)
227 (inst shr tmp n-positive-fixnum-bits)))
229 (define-vop (fixnump/signed-byte-64 type-predicate)
230 (:args (value :scs (signed-reg)))
232 (:conditional #.(if (= sb!vm:n-fixnum-tag-bits 1) :ns :z))
233 (:arg-types signed-num)
236 ;; Hackers Delight, p. 53: signed
237 ;; a <= x <= a + 2^n - 1
238 ;; is equivalent to unsigned
240 (inst mov rax-tn #.(- sb!xc:most-negative-fixnum))
241 (inst add rax-tn value)
242 (unless (= n-fixnum-tag-bits 1)
243 (inst shr rax-tn n-fixnum-bits))))
245 ;;; A (SIGNED-BYTE 64) can be represented with either fixnum or a bignum with
246 ;;; exactly one digit.
248 (define-vop (signed-byte-64-p type-predicate)
249 (:translate signed-byte-64-p)
251 (multiple-value-bind (yep nope)
253 (values not-target target)
254 (values target not-target))
255 (generate-fixnum-test value)
257 (move-qword-to-eax value)
258 (inst and al-tn lowtag-mask)
259 (inst cmp al-tn other-pointer-lowtag)
261 (inst cmp (make-ea-for-object-slot value 0 other-pointer-lowtag)
262 (+ (ash 1 n-widetag-bits) bignum-widetag))
263 (inst jmp (if not-p :ne :e) target))
266 (define-vop (check-signed-byte-64 check-type)
268 (let ((nope (generate-error-code vop
269 'object-not-signed-byte-64-error
271 (generate-fixnum-test value)
273 (move-qword-to-eax value)
274 (inst and al-tn lowtag-mask)
275 (inst cmp al-tn other-pointer-lowtag)
277 (inst cmp (make-ea-for-object-slot value 0 other-pointer-lowtag)
278 (+ (ash 1 n-widetag-bits) bignum-widetag))
281 (move result value)))
283 ;;; An (unsigned-byte 64) can be represented with either a positive
284 ;;; fixnum, a bignum with exactly one positive digit, or a bignum with
285 ;;; exactly two digits and the second digit all zeros.
286 (define-vop (unsigned-byte-64-p type-predicate)
287 (:translate unsigned-byte-64-p)
289 (let ((not-target (gen-label))
290 (single-word (gen-label))
291 (fixnum (gen-label)))
292 (multiple-value-bind (yep nope)
294 (values not-target target)
295 (values target not-target))
297 (generate-fixnum-test value)
301 ;; If not, is it an other pointer?
302 (inst and al-tn lowtag-mask)
303 (inst cmp al-tn other-pointer-lowtag)
306 (loadw rax-tn value 0 other-pointer-lowtag)
308 (inst cmp rax-tn (+ (ash 1 n-widetag-bits) bignum-widetag))
309 (inst jmp :e single-word)
310 ;; If it's other than two, we can't be an (unsigned-byte 64)
311 (inst cmp rax-tn (+ (ash 2 n-widetag-bits) bignum-widetag))
313 ;; Get the second digit.
314 (loadw rax-tn value (1+ bignum-digits-offset) other-pointer-lowtag)
315 ;; All zeros, its an (unsigned-byte 64).
316 (inst test rax-tn rax-tn)
320 (emit-label single-word)
321 ;; Get the single digit.
322 (loadw rax-tn value bignum-digits-offset other-pointer-lowtag)
324 ;; positive implies (unsigned-byte 64).
326 (inst test rax-tn rax-tn)
327 (inst jmp (if not-p :s :ns) target)
329 (emit-label not-target)))))
331 (define-vop (check-unsigned-byte-64 check-type)
334 (generate-error-code vop 'object-not-unsigned-byte-64-error value))
337 (single-word (gen-label)))
340 (generate-fixnum-test value)
344 ;; If not, is it an other pointer?
345 (inst and al-tn lowtag-mask)
346 (inst cmp al-tn other-pointer-lowtag)
349 (loadw rax-tn value 0 other-pointer-lowtag)
351 (inst cmp rax-tn (+ (ash 1 n-widetag-bits) bignum-widetag))
352 (inst jmp :e single-word)
353 ;; If it's other than two, we can't be an (unsigned-byte 64)
354 (inst cmp rax-tn (+ (ash 2 n-widetag-bits) bignum-widetag))
356 ;; Get the second digit.
357 (loadw rax-tn value (1+ bignum-digits-offset) other-pointer-lowtag)
358 ;; All zeros, its an (unsigned-byte 64).
359 (inst test rax-tn rax-tn)
363 (emit-label single-word)
364 ;; Get the single digit.
365 (loadw rax-tn value bignum-digits-offset other-pointer-lowtag)
367 ;; positive implies (unsigned-byte 64).
369 (inst test rax-tn rax-tn)
373 (move result value))))
375 ;;;; list/symbol types
377 ;;; symbolp (or symbol (eq nil))
378 ;;; consp (and list (not (eq nil)))
380 (define-vop (symbolp type-predicate)
383 (let ((is-symbol-label (if not-p DROP-THRU target)))
384 (inst cmp value nil-value)
385 (inst jmp :e is-symbol-label)
386 (test-type value target not-p (symbol-header-widetag)))
389 (define-vop (check-symbol check-type)
391 (let ((error (generate-error-code vop 'object-not-symbol-error value)))
392 (inst cmp value nil-value)
393 (inst jmp :e DROP-THRU)
394 (test-type value error t (symbol-header-widetag)))
396 (move result value)))
398 (define-vop (consp type-predicate)
401 (let ((is-not-cons-label (if not-p target DROP-THRU)))
402 (inst cmp value nil-value)
403 (inst jmp :e is-not-cons-label)
404 (test-type value target not-p (list-pointer-lowtag)))
407 (define-vop (check-cons check-type)
409 (let ((error (generate-error-code vop 'object-not-cons-error value)))
410 (inst cmp value nil-value)
412 (test-type value error t (list-pointer-lowtag))
413 (move result value))))