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 (inst lea eax-tn (make-ea :dword :base value :disp (- lowtag)))
84 (inst test al-tn lowtag-mask)
85 (inst jmp (if not-p :nz :z) 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 greater-or-equal when-true
92 ;; EQUAL, LESS-OR-EQUAL, and GREATER-OR-EQUAL are the conditions
93 ;; for branching to TARGET. WHEN-TRUE and WHEN-FALSE are the
94 ;; labels to branch to when we know it's true and when we know
95 ;; it's false respectively.
97 (values :ne :a :b drop-through target)
98 (values :e :na :nb target drop-through))
99 (%test-lowtag value when-false t lowtag)
100 (do ((remaining headers (cdr remaining))
101 ;; It is preferable (smaller and faster code) to directly
102 ;; compare the value in memory instead of loading it into
103 ;; a register first. Find out if this is possible and set
104 ;; WIDETAG-TN accordingly. If impossible, generate the
106 ;; Compared to x86 we additionally optimize the cases of a
107 ;; range starting with BIGNUM-WIDETAG or ending with
108 ;; COMPLEX-ARRAY-WIDETAG.
109 (widetag-tn (if (and (null (cdr headers))
110 (or (atom (car headers))
111 (= (caar headers) bignum-widetag)
112 (= (cdar headers) complex-array-widetag)))
113 (make-ea :byte :base value :disp (- lowtag))
115 (inst mov eax-tn (make-ea :dword :base value
119 (let ((header (car remaining))
120 (last (null (cdr remaining))))
123 (inst cmp widetag-tn header)
125 (inst jmp equal target)
126 (inst jmp :e when-true)))
128 (let ((start (car header))
131 ((= start bignum-widetag)
132 (inst cmp widetag-tn end)
134 (inst jmp less-or-equal target)
135 (inst jmp :be when-true)))
136 ((= end complex-array-widetag)
137 (inst cmp widetag-tn start)
139 (inst jmp greater-or-equal target)
140 (inst jmp :b when-false)))
142 (inst cmp al-tn start)
143 (inst jmp :b when-false)
145 (inst jmp :be when-true))
147 (inst sub al-tn start)
148 (inst cmp al-tn (- end start))
149 (inst jmp less-or-equal target))))))))
150 (emit-label drop-through))))
153 ;;;; type checking and testing
155 (define-vop (check-type)
156 (:args (value :target result :scs (any-reg descriptor-reg)))
157 (:results (result :scs (any-reg descriptor-reg)))
158 (:temporary (:sc unsigned-reg :offset eax-offset :to (:result 0)) eax)
161 (:save-p :compute-only))
163 (define-vop (type-predicate)
164 (:args (value :scs (any-reg descriptor-reg)))
165 (:temporary (:sc unsigned-reg :offset eax-offset) eax)
169 (:policy :fast-safe))
171 ;;; simpler VOP that don't need a temporary register
172 (define-vop (simple-check-type)
173 (:args (value :target result :scs (any-reg descriptor-reg)))
174 (:results (result :scs (any-reg descriptor-reg)
175 :load-if (not (and (sc-is value any-reg descriptor-reg)
176 (sc-is result control-stack)))))
178 (:save-p :compute-only))
180 (define-vop (simple-type-predicate)
181 (:args (value :scs (any-reg descriptor-reg control-stack)))
184 (:policy :fast-safe))
186 (defmacro !define-type-vops (pred-name check-name ptype error-code
188 &key (variant nil variant-p) &allow-other-keys)
189 ;; KLUDGE: UGH. Why do we need this eval? Can't we put this in the
191 (flet ((cost-to-test-types (type-codes)
192 (+ (* 2 (length type-codes))
193 (if (> (apply #'max type-codes) lowtag-limit) 7 2))))
194 (let* ((cost (cost-to-test-types (mapcar #'eval type-codes)))
195 (prefix (if variant-p
196 (concatenate 'string (string variant) "-")
200 `((define-vop (,pred-name ,(intern (concatenate 'string prefix "TYPE-PREDICATE")))
201 (:translate ,pred-name)
203 (test-type value target not-p (,@type-codes))))))
205 `((define-vop (,check-name ,(intern (concatenate 'string prefix "CHECK-TYPE")))
208 (generate-error-code vop ',error-code value)))
209 (test-type value err-lab t (,@type-codes))
210 (move result value))))))
212 `((primitive-type-vop ,check-name (:check) ,ptype)))))))
214 ;;;; other integer ranges
216 (define-vop (fixnump/unsigned-byte-64 simple-type-predicate)
217 (:args (value :scs (unsigned-reg)))
218 (:arg-types unsigned-num)
220 (:temporary (:sc unsigned-reg :from (:argument 0)) tmp)
225 (inst shr tmp n-positive-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)))
232 (:temporary (:sc unsigned-reg :offset eax-offset) eax)
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 (inst shr rax-tn n-fixnum-bits)))
244 #+#.(cl:if (cl:= sb!vm:n-fixnum-tag-bits 1) '(:and) '(:or))
245 (define-vop (fixnump/signed-byte-64 simple-type-predicate)
246 (:args (value :scs (signed-reg) :target temp))
249 (:temporary (:sc unsigned-reg :from (:argument 0)) temp)
250 (:arg-types signed-num)
254 ;; The overflow flag will be set if the reg's sign bit changes.
257 ;;; A (SIGNED-BYTE 64) can be represented with either fixnum or a bignum with
258 ;;; exactly one digit.
260 (define-vop (signed-byte-64-p type-predicate)
261 (:translate signed-byte-64-p)
263 (multiple-value-bind (yep nope)
265 (values not-target target)
266 (values target not-target))
267 (move-qword-to-eax value)
268 (inst test al-tn fixnum-tag-mask)
271 (inst and al-tn lowtag-mask)
272 (inst cmp al-tn other-pointer-lowtag)
274 (inst cmp (make-ea-for-object-slot value 0 other-pointer-lowtag)
275 (+ (ash 1 n-widetag-bits) bignum-widetag))
276 (inst jmp (if not-p :ne :e) target))
279 (define-vop (check-signed-byte-64 check-type)
281 (let ((nope (generate-error-code vop
282 'object-not-signed-byte-64-error
284 (generate-fixnum-test value)
286 (move-qword-to-eax value)
287 (inst and al-tn lowtag-mask)
288 (inst cmp al-tn other-pointer-lowtag)
290 (inst cmp (make-ea-for-object-slot value 0 other-pointer-lowtag)
291 (+ (ash 1 n-widetag-bits) bignum-widetag))
294 (move result value)))
296 ;;; An (unsigned-byte 64) can be represented with either a positive
297 ;;; fixnum, a bignum with exactly one positive digit, or a bignum with
298 ;;; exactly two digits and the second digit all zeros.
299 (define-vop (unsigned-byte-64-p type-predicate)
300 (:translate unsigned-byte-64-p)
302 (let ((not-target (gen-label))
303 (single-word (gen-label))
304 (fixnum (gen-label)))
305 (multiple-value-bind (yep nope)
307 (values not-target target)
308 (values target not-target))
311 (inst test al-tn fixnum-tag-mask)
314 ;; If not, is it an other pointer?
315 (inst and al-tn lowtag-mask)
316 (inst cmp al-tn other-pointer-lowtag)
319 (loadw rax-tn value 0 other-pointer-lowtag)
321 (inst cmp rax-tn (+ (ash 1 n-widetag-bits) bignum-widetag))
322 (inst jmp :e single-word)
323 ;; If it's other than two, we can't be an (unsigned-byte 64)
324 (inst cmp rax-tn (+ (ash 2 n-widetag-bits) bignum-widetag))
326 ;; Get the second digit.
327 (loadw rax-tn value (1+ bignum-digits-offset) other-pointer-lowtag)
328 ;; All zeros, its an (unsigned-byte 64).
329 (inst test rax-tn rax-tn)
333 (emit-label single-word)
334 ;; Get the single digit.
335 (loadw rax-tn value bignum-digits-offset other-pointer-lowtag)
337 ;; positive implies (unsigned-byte 64).
339 (inst test rax-tn rax-tn)
340 (inst jmp (if not-p :s :ns) target)
342 (emit-label not-target)))))
344 (define-vop (check-unsigned-byte-64 check-type)
347 (generate-error-code vop 'object-not-unsigned-byte-64-error value))
350 (single-word (gen-label)))
353 (generate-fixnum-test value)
357 ;; If not, is it an other pointer?
358 (inst and al-tn lowtag-mask)
359 (inst cmp al-tn other-pointer-lowtag)
362 (loadw rax-tn value 0 other-pointer-lowtag)
364 (inst cmp rax-tn (+ (ash 1 n-widetag-bits) bignum-widetag))
365 (inst jmp :e single-word)
366 ;; If it's other than two, we can't be an (unsigned-byte 64)
367 (inst cmp rax-tn (+ (ash 2 n-widetag-bits) bignum-widetag))
369 ;; Get the second digit.
370 (loadw rax-tn value (1+ bignum-digits-offset) other-pointer-lowtag)
371 ;; All zeros, its an (unsigned-byte 64).
372 (inst test rax-tn rax-tn)
376 (emit-label single-word)
377 ;; Get the single digit.
378 (loadw rax-tn value bignum-digits-offset other-pointer-lowtag)
380 ;; positive implies (unsigned-byte 64).
382 (inst test rax-tn rax-tn)
386 (move result value))))
388 (defun power-of-two-limit-p (x)
390 (= (logcount (1+ x)) 1)))
392 (define-vop (test-fixnum-mod-power-of-two)
393 (:args (value :scs (any-reg descriptor-reg
394 unsigned-reg signed-reg
397 (:constant (satisfies power-of-two-limit-p)))
398 (:translate fixnum-mod-p)
401 (:save-p :compute-only)
404 (aver (not (sc-is value immediate)))
405 (let* ((fixnum-hi (if (sc-is value unsigned-reg signed-reg)
408 (inst test value (constantize (lognot fixnum-hi))))))
410 (define-vop (test-fixnum-mod-tagged-unsigned)
411 (:args (value :scs (any-reg descriptor-reg
412 unsigned-reg signed-reg
414 (:arg-types (:or tagged-num unsigned-num signed-num)
416 (:translate fixnum-mod-p)
419 (:save-p :compute-only)
422 (aver (not (sc-is value immediate)))
423 (let ((fixnum-hi (if (sc-is value unsigned-reg signed-reg)
426 (inst cmp value (constantize fixnum-hi)))))
428 (define-vop (test-fixnum-mod-*)
429 (:args (value :scs (any-reg descriptor-reg)))
430 (:arg-types * (:constant fixnum))
431 (:translate fixnum-mod-p)
433 (:info target not-p hi)
434 (:save-p :compute-only)
437 (let* ((fixnum-hi (fixnumize hi))
439 (generate-fixnum-test value)
440 (inst jmp :ne (if not-p target skip))
441 (inst cmp value (constantize fixnum-hi))
442 (inst jmp (if not-p :a :be) target)
445 ;;;; list/symbol types
447 ;;; symbolp (or symbol (eq nil))
448 ;;; consp (and list (not (eq nil)))
450 (define-vop (symbolp type-predicate)
453 (let ((is-symbol-label (if not-p DROP-THRU target)))
454 (inst cmp value nil-value)
455 (inst jmp :e is-symbol-label)
456 (test-type value target not-p (symbol-header-widetag)))
459 (define-vop (check-symbol check-type)
461 (let ((error (generate-error-code vop 'object-not-symbol-error value)))
462 (inst cmp value nil-value)
463 (inst jmp :e DROP-THRU)
464 (test-type value error t (symbol-header-widetag)))
466 (move result value)))
468 (define-vop (consp type-predicate)
471 (let ((is-not-cons-label (if not-p target DROP-THRU)))
472 (inst cmp value nil-value)
473 (inst jmp :e is-not-cons-label)
474 (test-type value target not-p (list-pointer-lowtag)))
477 (define-vop (check-cons check-type)
479 (let ((error (generate-error-code vop 'object-not-cons-error value)))
480 (inst cmp value nil-value)
482 (test-type value error t (list-pointer-lowtag))
483 (move result value))))
487 (!define-type-vops simd-pack-p nil nil nil (simd-pack-widetag))
489 (define-vop (check-simd-pack check-type)
490 (:args (value :target result
491 :scs (any-reg descriptor-reg
492 int-sse-reg single-sse-reg double-sse-reg
493 int-sse-stack single-sse-stack double-sse-stack)))
494 (:results (result :scs (any-reg descriptor-reg
495 int-sse-reg single-sse-reg double-sse-reg)))
496 (:temporary (:sc unsigned-reg :offset eax-offset :to (:result 0)) eax)
500 (:save-p :compute-only)
503 ((int-sse-reg single-sse-reg double-sse-reg
504 int-sse-stack single-sse-stack double-sse-stack)
506 ((int-sse-reg single-sse-reg double-sse-reg)
508 ((any-reg descriptor-reg)
509 (with-fixed-allocation (result
513 ;; see *simd-pack-element-types*
516 ((int-sse-reg int-sse-stack) 0)
517 ((single-sse-reg single-sse-stack) 1)
518 ((double-sse-reg double-sse-stack) 2)))
519 result simd-pack-tag-slot other-pointer-lowtag)
520 (let ((ea (make-ea-for-object-slot
521 result simd-pack-lo-value-slot other-pointer-lowtag)))
522 (if (float-simd-pack-p value)
523 (inst movaps ea value)
524 (inst movdqa ea value)))))))
525 ((any-reg descriptor-reg)
526 (let ((leaf (sb!c::tn-leaf value)))
527 (unless (and (sb!c::lvar-p leaf)
528 (csubtypep (sb!c::lvar-type leaf)
529 (specifier-type 'simd-pack)))
532 (generate-error-code vop 'object-not-simd-pack-error value)
533 t (simd-pack-widetag))))
536 (let ((ea (make-ea-for-object-slot
537 value simd-pack-lo-value-slot other-pointer-lowtag)))
538 (inst movdqa result ea)))
539 ((single-sse-reg double-sse-reg)
540 (let ((ea (make-ea-for-object-slot
541 value simd-pack-lo-value-slot other-pointer-lowtag)))
542 (inst movaps result ea)))
543 ((any-reg descriptor-reg)
544 (move result value)))))))
546 (primitive-type-vop check-simd-pack (:check) simd-pack-int simd-pack-single simd-pack-double))