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 :from (:argument 0)) tmp)
227 (inst shr tmp n-positive-fixnum-bits)))
229 #-#.(cl:if (cl:= sb!vm:n-fixnum-tag-bits 1) '(:and) '(:or))
230 (define-vop (fixnump/signed-byte-64 simple-type-predicate)
231 (:args (value :scs (signed-reg)))
234 (:temporary (:sc unsigned-reg :offset eax-offset) eax)
235 (:arg-types signed-num)
238 ;; Hackers Delight, p. 53: signed
239 ;; a <= x <= a + 2^n - 1
240 ;; is equivalent to unsigned
242 (inst mov rax-tn #.(- sb!xc:most-negative-fixnum))
243 (inst add rax-tn value)
244 (inst shr rax-tn n-fixnum-bits)))
246 #+#.(cl:if (cl:= sb!vm:n-fixnum-tag-bits 1) '(:and) '(:or))
247 (define-vop (fixnump/signed-byte-64 simple-type-predicate)
248 (:args (value :scs (signed-reg) :target temp))
251 (:temporary (:sc unsigned-reg :from (:argument 0)) temp)
252 (:arg-types signed-num)
256 ;; The overflow flag will be set if the reg's sign bit changes.
259 ;;; A (SIGNED-BYTE 64) can be represented with either fixnum or a bignum with
260 ;;; exactly one digit.
262 (define-vop (signed-byte-64-p type-predicate)
263 (:translate signed-byte-64-p)
265 (multiple-value-bind (yep nope)
267 (values not-target target)
268 (values target not-target))
269 (generate-fixnum-test value)
271 (move-qword-to-eax value)
272 (inst and al-tn lowtag-mask)
273 (inst cmp al-tn other-pointer-lowtag)
275 (inst cmp (make-ea-for-object-slot value 0 other-pointer-lowtag)
276 (+ (ash 1 n-widetag-bits) bignum-widetag))
277 (inst jmp (if not-p :ne :e) target))
280 (define-vop (check-signed-byte-64 check-type)
282 (let ((nope (generate-error-code vop
283 'object-not-signed-byte-64-error
285 (generate-fixnum-test value)
287 (move-qword-to-eax value)
288 (inst and al-tn lowtag-mask)
289 (inst cmp al-tn other-pointer-lowtag)
291 (inst cmp (make-ea-for-object-slot value 0 other-pointer-lowtag)
292 (+ (ash 1 n-widetag-bits) bignum-widetag))
295 (move result value)))
297 ;;; An (unsigned-byte 64) can be represented with either a positive
298 ;;; fixnum, a bignum with exactly one positive digit, or a bignum with
299 ;;; exactly two digits and the second digit all zeros.
300 (define-vop (unsigned-byte-64-p type-predicate)
301 (:translate unsigned-byte-64-p)
303 (let ((not-target (gen-label))
304 (single-word (gen-label))
305 (fixnum (gen-label)))
306 (multiple-value-bind (yep nope)
308 (values not-target target)
309 (values target not-target))
311 (generate-fixnum-test value)
315 ;; If not, is it an other pointer?
316 (inst and al-tn lowtag-mask)
317 (inst cmp al-tn other-pointer-lowtag)
320 (loadw rax-tn value 0 other-pointer-lowtag)
322 (inst cmp rax-tn (+ (ash 1 n-widetag-bits) bignum-widetag))
323 (inst jmp :e single-word)
324 ;; If it's other than two, we can't be an (unsigned-byte 64)
325 (inst cmp rax-tn (+ (ash 2 n-widetag-bits) bignum-widetag))
327 ;; Get the second digit.
328 (loadw rax-tn value (1+ bignum-digits-offset) other-pointer-lowtag)
329 ;; All zeros, its an (unsigned-byte 64).
330 (inst test rax-tn rax-tn)
334 (emit-label single-word)
335 ;; Get the single digit.
336 (loadw rax-tn value bignum-digits-offset other-pointer-lowtag)
338 ;; positive implies (unsigned-byte 64).
340 (inst test rax-tn rax-tn)
341 (inst jmp (if not-p :s :ns) target)
343 (emit-label not-target)))))
345 (define-vop (check-unsigned-byte-64 check-type)
348 (generate-error-code vop 'object-not-unsigned-byte-64-error value))
351 (single-word (gen-label)))
354 (generate-fixnum-test value)
358 ;; If not, is it an other pointer?
359 (inst and al-tn lowtag-mask)
360 (inst cmp al-tn other-pointer-lowtag)
363 (loadw rax-tn value 0 other-pointer-lowtag)
365 (inst cmp rax-tn (+ (ash 1 n-widetag-bits) bignum-widetag))
366 (inst jmp :e single-word)
367 ;; If it's other than two, we can't be an (unsigned-byte 64)
368 (inst cmp rax-tn (+ (ash 2 n-widetag-bits) bignum-widetag))
370 ;; Get the second digit.
371 (loadw rax-tn value (1+ bignum-digits-offset) other-pointer-lowtag)
372 ;; All zeros, its an (unsigned-byte 64).
373 (inst test rax-tn rax-tn)
377 (emit-label single-word)
378 ;; Get the single digit.
379 (loadw rax-tn value bignum-digits-offset other-pointer-lowtag)
381 ;; positive implies (unsigned-byte 64).
383 (inst test rax-tn rax-tn)
387 (move result value))))
389 ;;;; list/symbol types
391 ;;; symbolp (or symbol (eq nil))
392 ;;; consp (and list (not (eq nil)))
394 (define-vop (symbolp type-predicate)
397 (let ((is-symbol-label (if not-p DROP-THRU target)))
398 (inst cmp value nil-value)
399 (inst jmp :e is-symbol-label)
400 (test-type value target not-p (symbol-header-widetag)))
403 (define-vop (check-symbol check-type)
405 (let ((error (generate-error-code vop 'object-not-symbol-error value)))
406 (inst cmp value nil-value)
407 (inst jmp :e DROP-THRU)
408 (test-type value error t (symbol-header-widetag)))
410 (move result value)))
412 (define-vop (consp type-predicate)
415 (let ((is-not-cons-label (if not-p target DROP-THRU)))
416 (inst cmp value nil-value)
417 (inst jmp :e is-not-cons-label)
418 (test-type value target not-p (list-pointer-lowtag)))
421 (define-vop (check-cons check-type)
423 (let ((error (generate-error-code vop 'object-not-cons-error value)))
424 (inst cmp value nil-value)
426 (test-type value error t (list-pointer-lowtag))
427 (move result value))))