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 (defmacro !define-type-vops (pred-name check-name ptype error-code
189 &key (variant nil variant-p) &allow-other-keys)
190 ;; KLUDGE: UGH. Why do we need this eval? Can't we put this in the
192 (flet ((cost-to-test-types (type-codes)
193 (+ (* 2 (length type-codes))
194 (if (> (apply #'max type-codes) lowtag-limit) 7 2))))
195 (let* ((cost (cost-to-test-types (mapcar #'eval type-codes)))
196 (prefix (if variant-p
197 (concatenate 'string (string variant) "-")
201 `((define-vop (,pred-name ,(intern (concatenate 'string prefix "TYPE-PREDICATE")))
202 (:translate ,pred-name)
204 (test-type value target not-p (,@type-codes))))))
206 `((define-vop (,check-name ,(intern (concatenate 'string prefix "CHECK-TYPE")))
209 (generate-error-code vop ',error-code value)))
210 (test-type value err-lab t (,@type-codes))
211 (move result value))))))
213 `((primitive-type-vop ,check-name (:check) ,ptype)))))))
215 ;;;; other integer ranges
217 (define-vop (fixnump/unsigned-byte-64 simple-type-predicate)
218 (:args (value :scs (unsigned-reg)))
219 (:arg-types unsigned-num)
221 (:temporary (:sc unsigned-reg :from (:argument 0)) tmp)
226 (inst shr tmp n-positive-fixnum-bits)))
228 #-#.(cl:if (cl:= sb!vm:n-fixnum-tag-bits 1) '(:and) '(:or))
229 (define-vop (fixnump/signed-byte-64 simple-type-predicate)
230 (:args (value :scs (signed-reg)))
233 (:temporary (:sc unsigned-reg :offset eax-offset) eax)
234 (:arg-types signed-num)
237 ;; Hackers Delight, p. 53: signed
238 ;; a <= x <= a + 2^n - 1
239 ;; is equivalent to unsigned
241 (inst mov rax-tn #.(- sb!xc:most-negative-fixnum))
242 (inst add rax-tn value)
243 (inst shr rax-tn n-fixnum-bits)))
245 #+#.(cl:if (cl:= sb!vm:n-fixnum-tag-bits 1) '(:and) '(:or))
246 (define-vop (fixnump/signed-byte-64 simple-type-predicate)
247 (:args (value :scs (signed-reg) :target temp))
250 (:temporary (:sc unsigned-reg :from (:argument 0)) temp)
251 (:arg-types signed-num)
255 ;; The overflow flag will be set if the reg's sign bit changes.
258 ;;; A (SIGNED-BYTE 64) can be represented with either fixnum or a bignum with
259 ;;; exactly one digit.
261 (define-vop (signed-byte-64-p type-predicate)
262 (:translate signed-byte-64-p)
264 (multiple-value-bind (yep nope)
266 (values not-target target)
267 (values target not-target))
268 (generate-fixnum-test value)
270 (move-qword-to-eax value)
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))
310 (generate-fixnum-test value)
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 ;;;; list/symbol types
390 ;;; symbolp (or symbol (eq nil))
391 ;;; consp (and list (not (eq nil)))
393 (define-vop (symbolp type-predicate)
396 (let ((is-symbol-label (if not-p DROP-THRU target)))
397 (inst cmp value nil-value)
398 (inst jmp :e is-symbol-label)
399 (test-type value target not-p (symbol-header-widetag)))
402 (define-vop (check-symbol check-type)
404 (let ((error (generate-error-code vop 'object-not-symbol-error value)))
405 (inst cmp value nil-value)
406 (inst jmp :e DROP-THRU)
407 (test-type value error t (symbol-header-widetag)))
409 (move result value)))
411 (define-vop (consp type-predicate)
414 (let ((is-not-cons-label (if not-p target DROP-THRU)))
415 (inst cmp value nil-value)
416 (inst jmp :e is-not-cons-label)
417 (test-type value target not-p (list-pointer-lowtag)))
420 (define-vop (check-cons check-type)
422 (let ((error (generate-error-code vop 'object-not-cons-error value)))
423 (inst cmp value nil-value)
425 (test-type value error t (list-pointer-lowtag))
426 (move result value))))
430 (!define-type-vops simd-pack-p nil nil nil (simd-pack-widetag))
433 (define-vop (check-simd-pack check-type)
434 (:args (value :target result
435 :scs (any-reg descriptor-reg
436 int-sse-reg single-sse-reg double-sse-reg
437 int-sse-stack single-sse-stack double-sse-stack)))
438 (:results (result :scs (any-reg descriptor-reg
439 int-sse-reg single-sse-reg double-sse-reg)))
440 (:temporary (:sc unsigned-reg :offset eax-offset :to (:result 0)) eax)
444 (:save-p :compute-only)
447 ((int-sse-reg single-sse-reg double-sse-reg
448 int-sse-stack single-sse-stack double-sse-stack)
450 ((int-sse-reg single-sse-reg double-sse-reg)
452 ((any-reg descriptor-reg)
453 (with-fixed-allocation (result
457 ;; see *simd-pack-element-types*
460 ((int-sse-reg int-sse-stack) 0)
461 ((single-sse-reg single-sse-stack) 1)
462 ((double-sse-reg double-sse-stack) 2)))
463 result simd-pack-tag-slot other-pointer-lowtag)
464 (let ((ea (make-ea-for-object-slot
465 result simd-pack-lo-value-slot other-pointer-lowtag)))
466 (if (float-simd-pack-p value)
467 (inst movaps ea value)
468 (inst movdqa ea value)))))))
469 ((any-reg descriptor-reg)
470 (let ((leaf (sb!c::tn-leaf value)))
471 (unless (and (sb!c::lvar-p leaf)
472 (csubtypep (sb!c::lvar-type leaf)
473 (specifier-type 'simd-pack)))
476 (generate-error-code vop 'object-not-simd-pack-error value)
477 t (simd-pack-widetag))))
480 (let ((ea (make-ea-for-object-slot
481 value simd-pack-lo-value-slot other-pointer-lowtag)))
482 (inst movdqa result ea)))
483 ((single-sse-reg double-sse-reg)
484 (let ((ea (make-ea-for-object-slot
485 value simd-pack-lo-value-slot other-pointer-lowtag)))
486 (inst movaps result ea)))
487 ((any-reg descriptor-reg)
488 (move result value)))))))
490 (primitive-type-vop check-simd-pack (:check) simd-pack-int simd-pack-single simd-pack-double))