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 (defun generate-fixnum-test (value)
17 "Set the Z flag if VALUE is fixnum"
19 (cond ((ea-p value
) value
) ; merged a memory load + fixnump vop
20 ((sc-is value control-stack
)
21 (ea (frame-byte-offset (tn-offset value
)) rbp-tn
))
23 ;; Don't check for (ANY-REG DESCRIPTOR-REG) because VALUE
24 ;; can have a "weird" SC that would not have tag bits.
25 ;; Sometimes a vop temp is specified as UNSIGNED-REG, e.g.
29 (defun %test-fixnum
(value temp target not-p
)
30 (declare (ignore temp
))
31 (generate-fixnum-test value
)
32 (inst jmp
(if not-p
:nz
:z
) target
))
34 (defun %lea-for-lowtag-test
(temp value lowtag
&optional
(operand-size :dword
))
35 ;; If OPERAND-SIZE is :QWORD, then instead of discarding the upper 32 bits
36 ;; in a lowtag test, preserve the full word which becomes an untagged pointer.
37 ;; The REX byte can't be avoided if VALUE is R8 or higher, so it costs nothing
38 ;; to widen the LEA operand. In this way, we avoid emitting a displacement to
39 ;; load the widetag. The total number of bytes emitted is reduced by 1,
40 ;; or by nothing. ASSUMPTION: tagged pointer causes conservative pinning,
41 ;; hence an untagged pointer remains valid.
42 (inst lea operand-size temp
(ea (- lowtag
) value
)))
44 ;; Numerics including fixnum, excluding short-float. (INTEGER,RATIONAL)
45 (defun %test-fixnum-and-headers
(value temp target not-p headers
46 &key value-tn-ref immediate-tested
)
47 (let ((drop-through (gen-label)))
48 (case n-fixnum-tag-bits
50 (%lea-for-lowtag-test temp value other-pointer-lowtag
:qword
)
51 (when (types-equal-or-intersect (tn-ref-type value-tn-ref
)
52 (specifier-type 'fixnum
))
53 (inst test
:byte temp
1)
54 (inst jmp
:nz
(if not-p drop-through target
))) ; inverted
55 (%test-headers value temp target not-p nil headers
56 :drop-through drop-through
:compute-temp nil
57 :value-tn-ref value-tn-ref
58 :immediate-tested immediate-tested
))
60 (generate-fixnum-test value
)
61 (inst jmp
:z
(if not-p drop-through target
))
62 (%test-headers value temp target not-p nil headers
63 :drop-through drop-through
64 :immediate-tested immediate-tested
)))))
67 (defun %test-fixnum-immediate-and-headers
(value temp target not-p immediate headers
68 &key value-tn-ref immediate-tested
)
69 (let ((drop-through (gen-label)))
70 (case n-fixnum-tag-bits
72 (%lea-for-lowtag-test temp value other-pointer-lowtag
:qword
)
73 (when (types-equal-or-intersect (tn-ref-type value-tn-ref
)
74 (specifier-type 'fixnum
))
75 (inst test
:byte temp
1)
76 (inst jmp
:nz
(if not-p drop-through target
))) ; inverted
77 (when (or (/= immediate single-float-widetag
)
78 (types-equal-or-intersect (tn-ref-type value-tn-ref
)
79 (specifier-type 'single-float
)))
80 (inst cmp
:byte temp
(- immediate other-pointer-lowtag
))
81 (inst jmp
:e
(if not-p drop-through target
)))
83 (%test-headers value temp target not-p nil headers
84 :drop-through drop-through
:compute-temp nil
85 :value-tn-ref value-tn-ref
86 :immediate-tested immediate-tested
))
87 (t (generate-fixnum-test value
)
88 (inst jmp
:z
(if not-p drop-through target
))
89 (%test-immediate-and-headers value temp target not-p immediate headers
90 :drop-through drop-through
91 :immediate-tested immediate-tested
)))))
93 (defun %test-immediate
(value temp target not-p immediate
95 (declare (ignore temp value-tn-ref
))
96 (inst cmp
:byte value immediate
)
97 (inst jmp
(if not-p
:ne
:e
) target
))
99 ;; Numerics including short-float, excluding fixnum
100 (defun %test-immediate-and-headers
(value temp target not-p immediate headers
101 &key
(drop-through (gen-label))
104 ;; Code a single instruction byte test if possible.
105 (cond ((sc-is value any-reg descriptor-reg
)
106 (inst cmp
:byte value immediate
))
108 (move temp value
) ; FIXME - why load?
109 (inst cmp
:byte temp immediate
)))
110 (inst jmp
:e
(if not-p drop-through target
))
111 (%test-headers value temp target not-p nil headers
112 :drop-through drop-through
113 :value-tn-ref value-tn-ref
114 :immediate-tested immediate-tested
))
116 (defun %test-lowtag
(value temp target not-p lowtag
&key value-tn-ref
)
117 (declare (ignore value-tn-ref
))
118 (%lea-for-lowtag-test temp value lowtag
)
119 (inst test
:byte temp lowtag-mask
)
120 (inst jmp
(if not-p
:nz
:z
) target
))
122 (defun %test-headers
(value temp target not-p function-p headers
124 (drop-through (gen-label))
126 (compute-temp load-widetag
)
129 (let* ((lowtag (if function-p fun-pointer-lowtag other-pointer-lowtag
))
130 ;; It is preferable (smaller and faster code) to directly
131 ;; compare the value in memory instead of loading it into
132 ;; a register first. Find out if this is possible and set
133 ;; WIDETAG-TN accordingly. If impossible, generate the
135 (widetag-tn (if (and load-widetag
138 (or (atom (car headers
))
139 (= (caar headers
) bignum-widetag
)
140 (= (cdar headers
) complex-array-widetag
)))
141 (ea (- lowtag
) value
)
143 (first (car headers
))
144 (second (cadr headers
))
147 (multiple-value-bind (equal less-or-equal greater-or-equal when-true
149 ;; EQUAL, LESS-OR-EQUAL, and GREATER-OR-EQUAL are the conditions
150 ;; for branching to TARGET. WHEN-TRUE and WHEN-FALSE are the
151 ;; labels to branch to when we know it's true and when we know
152 ;; it's false respectively.
154 (values :ne
:a
:b drop-through target
)
155 (values :e
:na
:nb target drop-through
))
157 (cond ((not load-widetag
))
159 (eq lowtag other-pointer-lowtag
)
160 (other-pointer-tn-ref-p value-tn-ref t immediate-tested
))) ; best case: lowtag is right
162 ;; If HEADERS contains a range, then list pointers have to be
163 ;; disallowed - consider a list whose CAR has a fixnum that
164 ;; spuriously matches the range test.
165 (if (some #'listp headers
)
166 (headered-object-pointer-tn-ref-p value-tn-ref
)
167 (pointer-tn-ref-p value-tn-ref
)))
168 ;; Emit one fewer conditional jump than the general case,
169 (inst mov temp value
)
170 (inst and temp
(lognot lowtag-mask
))
171 (if (ea-p widetag-tn
)
172 (setq widetag-tn
(ea temp
))
173 (setq untagged
(ea temp
))))
175 ;; Regardless of whether :COMPUTE-TEMP is T or NIL, it will hold
176 ;; an untagged ptr to VALUE if the lowtag test passes.
177 (setq untagged
(ea temp
))
178 (when (ea-p widetag-tn
)
179 (setq widetag-tn untagged
))
181 (%lea-for-lowtag-test temp value lowtag
:qword
))
182 (inst test
:byte temp lowtag-mask
)
183 (inst jmp
:nz when-false
)))
185 (when (and load-widetag
186 (eq widetag-tn temp
))
187 (inst mov
:dword temp
(or untagged
(ea (- lowtag
) value
))))
188 (dolist (widetag except
)
189 (inst cmp
:byte temp widetag
)
190 (inst jmp
:e when-false
))
193 ((and (fixnump first
)
196 (= (logcount (logxor first second
)) 1))
197 ;; Two widetags differing at one bit. Use one cmp and branch.
198 ;; Start by ORing in the bit that they differ on.
199 (let ((diff-bit (logxor first second
)))
200 (aver (not (ea-p widetag-tn
))) ; can't clobber a header
201 (inst or
:byte widetag-tn diff-bit
)
202 (inst cmp
:byte widetag-tn
(logior first diff-bit
))
203 (if not-p
(inst jmp
:ne target
) (inst jmp
:eq target
))))
205 ;; Compared to x86 we additionally optimize the cases of a
206 ;; range starting with BIGNUM-WIDETAG (= min widetag)
207 ;; or ending with COMPLEX-ARRAY-WIDETAG (= max widetag)
208 (do ((remaining headers
(cdr remaining
)))
210 (let ((header (car remaining
))
211 (last (null (cdr remaining
))))
213 ((and (eql header simple-array-widetag
)
215 (csubtypep (tn-ref-type value-tn-ref
) (specifier-type 'string
))))
217 (inst cmp
:byte widetag-tn header
)
219 (inst jmp equal target
)
220 (inst jmp
:e when-true
)))
222 (let ((start (car header
))
225 ((= start bignum-widetag
)
226 (inst cmp
:byte widetag-tn end
)
228 (inst jmp less-or-equal target
)
229 (inst jmp
:be when-true
)))
230 ((= end complex-array-widetag
)
231 (inst cmp
:byte widetag-tn start
)
233 (inst jmp greater-or-equal target
)
234 (inst jmp
:b when-false
)))
236 (inst cmp
:byte temp start
)
237 (inst jmp
:b when-false
)
238 (inst cmp
:byte temp end
)
239 (inst jmp
:be when-true
))
241 (inst sub
:byte temp start
)
242 (inst cmp
:byte temp
(- end start
))
243 (inst jmp less-or-equal target
))))))))))
245 (emit-label drop-through
))))
247 ;;;; other integer ranges
249 (define-vop (simple-type-predicate)
250 (:args
(value :scs
(any-reg descriptor-reg control-stack
)))
253 (:policy
:fast-safe
))
255 (define-vop (fixnump/unsigned-byte-64 simple-type-predicate
)
256 (:args
(value :scs
(unsigned-reg)))
257 (:arg-types unsigned-num
)
259 (:temporary
(:sc unsigned-reg
:from
(:argument
0)) tmp
)
263 (inst shr tmp n-positive-fixnum-bits
)))
265 #-
#.
(cl:if
(cl:= sb-vm
:n-fixnum-tag-bits
1) '(:and
) '(:or
))
266 (define-vop (fixnump/signed-byte-64 simple-type-predicate
)
267 (:args
(value :scs
(signed-reg)))
269 (:temporary
(:sc unsigned-reg
) temp
)
270 (:arg-types signed-num
)
273 ;; Hackers Delight, p. 53: signed
274 ;; a <= x <= a + 2^n - 1
275 ;; is equivalent to unsigned
277 (inst mov temp
#.
(- most-negative-fixnum
))
278 (inst add temp value
)
279 (inst shr temp n-fixnum-bits
)))
281 #+#.
(cl:if
(cl:= sb-vm
:n-fixnum-tag-bits
1) '(:and
) '(:or
))
282 (define-vop (fixnump/signed-byte-64 simple-type-predicate
)
283 (:args
(value :scs
(signed-reg) :target temp
))
285 (:temporary
(:sc unsigned-reg
:from
(:argument
0)) temp
)
286 (:arg-types signed-num
)
290 ;; The overflow flag will be set if the reg's sign bit changes.
293 ;;; A (SIGNED-BYTE 64) can be represented with either fixnum or a bignum with
294 ;;; exactly one digit.
296 (define-vop (pointerp)
297 (:args
(value :scs
(any-reg descriptor-reg
)))
298 (:temporary
(:sc unsigned-reg
:from
(:argument
0)) temp
)
301 (:translate pointerp
)
303 (if (location= temp value
) (inst sub
:dword value
3) (inst lea
:dword temp
(ea -
3 value
)))
304 (inst test
:byte temp
#b11
)))
306 ;; A fixnum or single-digit bignum satisfies signed-byte-64-p
307 (define-vop (signed-byte-64-p pointerp
)
308 (:translate signed-byte-64-p
)
312 (when (types-equal-or-intersect (tn-ref-type arg-ref
) (specifier-type 'fixnum
))
313 (inst test
:byte value fixnum-tag-mask
)
314 (inst jmp
:z out
)) ; good
315 (let ((ea (cond ((fixnum-or-other-pointer-tn-ref-p arg-ref t
)
316 (ea (- other-pointer-lowtag
) value
))
318 (%lea-for-lowtag-test temp value other-pointer-lowtag
:qword
)
319 (inst test
:byte temp lowtag-mask
)
322 (inst cmp
:qword ea
(bignum-header-for-length 1)))
325 (define-vop (signed-byte-64-p/unsigned
)
326 (:args
(value :scs
(unsigned-reg)))
327 (:arg-types unsigned-num
)
330 (:translate signed-byte-64-p
)
332 (inst test value value
)))
334 (macrolet ((define (name src-size
)
335 `(define-vop (,(symbolicate name
"/SIGNED"))
337 (:args
(value :scs
(signed-reg)))
338 (:arg-types signed-num
)
341 (:temporary
(:sc unsigned-reg
) temp
)
343 (inst movsx
'(,src-size
:qword
) temp value
)
344 (inst cmp temp value
)))))
345 (define signed-byte-8-p
:byte
)
346 (define signed-byte-16-p
:word
)
347 (define signed-byte-32-p
:dword
))
349 (define-vop (signed-byte-8-p)
350 (:translate signed-byte-8-p
)
351 (:args
(value :scs
(any-reg descriptor-reg
)))
355 (:temporary
(:sc unsigned-reg
) temp
)
357 (inst lea temp
(ea (ash (expt 2 7) n-fixnum-tag-bits
) value
))
358 (inst test temp
(lognot (fixnumize (1- (expt 2 8)))))))
360 (define-vop (signed-byte-16-p)
361 (:translate signed-byte-16-p
)
362 (:args
(value :scs
(any-reg descriptor-reg
)))
366 (:temporary
(:sc unsigned-reg
) temp
)
368 (inst lea temp
(ea (ash (expt 2 15) n-fixnum-tag-bits
) value
))
369 (inst test temp
(lognot (fixnumize (1- (expt 2 16)))))))
371 (define-vop (signed-byte-32-p)
372 (:translate signed-byte-32-p
)
373 (:args
(value :scs
(any-reg descriptor-reg
)))
377 (:temporary
(:sc unsigned-reg
) temp temp2
)
380 (inst sar temp n-fixnum-tag-bits
)
381 (inst movsx
'(:dword
:qword
) temp2 temp
)
382 (inst cmp temp2 temp
)
383 (unless (csubtypep (tn-ref-type arg-ref
) (specifier-type 'fixnum
))
385 (inst test
:byte value fixnum-tag-mask
))
388 ;;; Sign bit and fixnum tag bit.
389 (defconstant non-negative-fixnum-mask-constant
391 (defconstant non-negative-fixnum-mask-constant-wired-address
392 (+ static-space-start
(* 12 n-word-bytes
)))
393 ;; the preceding constant is embedded in an array,
394 ;; the header of which must not overlap the static alloc regions
396 (aver (>= (- non-negative-fixnum-mask-constant-wired-address
(* 2 n-word-bytes
))
397 (+ static-space-start
398 (max boxed-region-offset
401 (* 3 n-word-bytes
))))
403 ;;; An (unsigned-byte 64) can be represented with either a positive
404 ;;; fixnum, a bignum with exactly one positive digit, or a bignum with
405 ;;; exactly two digits and the second digit all zeros.
406 (define-vop (unsigned-byte-64-p type-predicate
)
407 (:translate unsigned-byte-64-p
)
409 (let* ((not-target (gen-label))
410 (single-word (gen-label))
411 (fixnum-p (types-equal-or-intersect (tn-ref-type args
) (specifier-type 'fixnum
)))
412 (not-signed-byte-64-p (not (types-equal-or-intersect (tn-ref-type args
) (specifier-type 'signed-word
))))
413 (unsigned-p (or not-signed-byte-64-p
414 (not (types-equal-or-intersect (tn-ref-type args
) (specifier-type '(integer * -
1)))))))
415 (multiple-value-bind (yep nope
)
417 (values not-target target
)
418 (values target not-target
))
421 (inst test
:byte value fixnum-tag-mask
)
423 (t ;; Is it a fixnum with the sign bit clear?
424 (inst test
(ea non-negative-fixnum-mask-constant-wired-address
) value
)
426 (cond ((fixnum-or-other-pointer-tn-ref-p args t
)
429 (inst test
:byte value fixnum-tag-mask
)
432 (%lea-for-lowtag-test temp value other-pointer-lowtag
)
433 (inst test
:byte temp lowtag-mask
)
434 (inst jmp
:ne nope
)))
436 (loadw temp value
0 other-pointer-lowtag
)
437 (unless not-signed-byte-64-p
439 (inst cmp temp
(bignum-header-for-length 1))
440 (inst jmp
:e
(if unsigned-p
443 ;; If it's other than two, we can't be an (unsigned-byte 64)
444 ;: Leave TEMP holding 0 in the affirmative case.
445 (inst sub temp
(bignum-header-for-length 2))
447 ;; Compare the second digit to zero (in TEMP).
448 (inst cmp
(object-slot-ea value
(1+ bignum-digits-offset
) other-pointer-lowtag
)
451 (inst jmp
(if not-p
:nz
:z
) target
))
453 (inst jmp
:z yep
) ; All zeros, its an (unsigned-byte 64).
457 (emit-label single-word
)
458 ;; Get the single digit.
459 (loadw temp value bignum-digits-offset other-pointer-lowtag
)
460 ;; positive implies (unsigned-byte 64).
461 (inst test temp temp
)
462 (inst jmp
(if not-p
:s
:ns
) target
))
464 (emit-label not-target
)))))
466 (define-vop (unsigned-byte-x-p type-predicate
)
467 (:arg-types
* (:constant
(integer 1)))
468 (:translate sb-c
::unsigned-byte-x-p
)
469 (:info target not-p x
)
470 (:temporary
(:sc unsigned-reg
) last-digit
)
472 (let* ((type (tn-ref-type args
))
473 (fixnum-p (types-equal-or-intersect type
(specifier-type 'fixnum
)))
474 (integer-p (csubtypep type
(specifier-type 'integer
)))
475 (unsigned-p (not (types-equal-or-intersect type
(specifier-type '(integer * -
1))))))
476 (multiple-value-bind (yep nope
)
478 (values not-target target
)
479 (values target not-target
))
483 (inst test
:byte value fixnum-tag-mask
)
485 (t ;; Is it a fixnum with the sign bit clear?
486 (inst test
(ea non-negative-fixnum-mask-constant-wired-address
) value
)
488 (cond ((fixnum-or-other-pointer-tn-ref-p args t
)
491 (inst test
:byte value fixnum-tag-mask
)
494 (%lea-for-lowtag-test temp value other-pointer-lowtag
)
495 (inst test
:byte temp lowtag-mask
)
496 (inst jmp
:ne nope
)))
498 (loadw temp value
0 other-pointer-lowtag
)
500 (inst cmp
:byte temp bignum-widetag
)
502 (inst shr temp n-widetag-bits
)
503 (inst cmp
:dword temp
(1+ (/ x n-word-bits
)))
505 ;; Is it a sign-extended sign bit
508 (inst cmp
:dword
(ea (+ (- other-pointer-lowtag
) (/ n-word-bytes
2))
509 value temp n-word-bytes
)
511 (inst jmp
(if not-p
:nz
:z
) target
))
513 (inst mov last-digit
(ea (- other-pointer-lowtag
) value temp n-word-bytes
))
515 (inst test last-digit last-digit
)
516 (inst jmp
:nz nope
)))
519 (inst test last-digit last-digit
)
520 (inst jmp
(if not-p
:s
:ns
) target
)))))
523 ;;; SINGLE-FLOAT-P, CHARACTERP, UNBOUND-MARKER-P produce a flag result
524 ;;; and never need a temporary.
525 (macrolet ((define (name widetag
)
526 `(define-vop (,name simple-type-predicate
)
529 (:generator
1 (inst cmp
:byte value
,widetag
)))))
530 (define single-float-p single-float-widetag
)
531 (define characterp character-widetag
)
532 (define unbound-marker-p unbound-marker-widetag
))
534 ;;; FUNCTIONP, LISTP, %INSTANCEP, %OTHER-POINTER-P produce a flag result
535 (macrolet ((define (name lowtag
)
536 `(define-vop (,name pointerp
)
539 (if (location= temp value
)
540 (inst sub
:dword value
,lowtag
)
541 (inst lea
:dword temp
(ea (- ,lowtag
) value
)))
542 (inst test
:byte temp lowtag-mask
)))))
543 (define functionp fun-pointer-lowtag
)
544 (define listp list-pointer-lowtag
)
545 (define %instancep instance-pointer-lowtag
)
546 (define %other-pointer-p other-pointer-lowtag
))
548 ;;; Function subtypes produce a flag result
549 (macrolet ((define (name widetag
)
550 `(define-vop (,name type-predicate
)
552 (:info
) ; nullify the info
555 (inst lea temp
(ea (- fun-pointer-lowtag
) value
))
556 (inst test
:byte temp lowtag-mask
)
558 (inst cmp
:byte
(ea temp
) ,widetag
)
560 (define closurep closure-widetag
)
561 (define simple-fun-p simple-fun-widetag
)
562 (define funcallable-instance-p funcallable-instance-widetag
))
563 ;;; Various OTHER-POINTER objects produce a flag result.
564 ;;; The parens around widetag are from copy&paste of generic/type-vops
565 (macrolet ((define (name (widetag))
566 `(define-vop (,name type-predicate
)
568 (:info
) ; nullify the info
571 (test-other-ptr value args
,widetag temp out
)
573 (define bignump
(bignum-widetag))
574 (define ratiop
(ratio-widetag))
575 (define complex-rational-p
(complex-rational-widetag))
576 (define complex-single-float-p
(complex-single-float-widetag))
577 (define complex-double-float-p
(complex-double-float-widetag))
578 (define double-float-p
(double-float-widetag))
579 (define system-area-pointer-p
(sap-widetag))
580 (define weak-pointer-p
(weak-pointer-widetag))
581 (define code-component-p
(code-header-widetag))
582 (define fdefn-p
(fdefn-widetag))
583 (define simple-array-header-p
(simple-array-widetag))
584 (define complex-vector-p
(complex-vector-widetag)))
586 (macrolet ((fail-if-not-otherptr ()
587 `(cond ((other-pointer-tn-ref-p value-tn-ref t
)
588 (inst mov
:byte temp
(ea (- other-pointer-lowtag
) value
)))
590 (inst lea temp
(ea (- other-pointer-lowtag
) value
))
591 (inst test
:byte temp lowtag-mask
)
592 ;; TEST clears the Carry, so if this jump occurs,
593 ;; it returns the correct answer for the vops that return
594 ;; their result in Z or C.
596 (inst mov
:byte temp
(ea temp
))))))
598 (macrolet ((define (name (simple nonsimple
))
599 (aver (= (logior 8 (symbol-value simple
)) (symbol-value nonsimple
)))
600 `(define-vop (,name type-predicate
)
602 (:info
) ; nullify the info
604 (:arg-refs value-tn-ref
)
606 (fail-if-not-otherptr)
607 (inst or
:byte temp
8)
608 (inst cmp
:byte temp
,nonsimple
)
610 (define base-string-p
(simple-base-string-widetag complex-base-string-widetag
))
611 (define character-string-p
612 (simple-character-string-widetag complex-character-string-widetag
)))
613 (macrolet ((define (name widetags
)
614 (let* ((widetags (symbol-value widetags
))
615 (min (reduce #'min widetags
))
616 (max (reduce #'max widetags
)))
617 `(define-vop (,name type-predicate
)
620 (:conditional
:c
) ; Carry flag = "below" (unsigned)
621 (:arg-refs value-tn-ref
)
623 (fail-if-not-otherptr)
624 (inst sub
:byte temp
,min
)
625 (inst cmp
:byte temp
,(1+ (- max min
)))
627 (define simple-rank-1-array-
*-p
+simple-rank-1-array-widetags
+)
628 (define vectorp
+vector-widetags
+)
629 (define simple-array-p
+simple-array-widetags
+)
630 #+sb-unicode
(define stringp
+string-widetags
+)))
632 ;;;; list/symbol types
634 ;;; symbolp (or symbol (eq nil))
635 ;;; consp (and list (not (eq nil)))
637 ;;; Test whether ARG is an other-pointer to WIDETAG, setting the Z flag if so
638 (defun test-other-ptr (arg arg-ref widetag temp label
&optional
(permit-nil t
))
640 (cond ((other-pointer-tn-ref-p arg-ref permit-nil
)
641 (ea (- other-pointer-lowtag
) arg
))
643 (%lea-for-lowtag-test temp arg other-pointer-lowtag
:qword
)
644 (inst test
:byte temp lowtag-mask
)
649 (define-vop (symbolp type-predicate
)
654 ;; If the VALUE were known to be an OTHER-POINTER, the IR1 lvar type
655 ;; can't intersect NULL. So the IR1 should have been transformed to NON-NULL-SYMBOL-P.
656 ;; Hence this must *not* be known to be an OTHER-POINTER.
657 (aver (not (other-pointer-tn-ref-p args
)))
658 (if (other-pointer-tn-ref-p args t
) ; allow NIL
659 (inst cmp
:byte
(ea (- other-pointer-lowtag
) value
) symbol-widetag
)
661 (%lea-for-lowtag-test temp value other-pointer-lowtag
:qword
)
662 (inst test
:byte temp lowtag-mask
)
663 (inst jmp
:e compare-widetag
)
664 (inst cmp value nil-value
)
667 (inst cmp
:byte
(ea temp
) symbol-widetag
)))
670 (define-vop (non-null-symbol-p symbolp
)
671 (:translate non-null-symbol-p
)
673 (test-other-ptr value args symbol-widetag temp out nil
)
676 ;;; It would be far better if we could recognize the IR1 for
677 ;;; (AND (CONSP X) (EQ (CAR X) 'FOO))
678 ;;; rather than treating (TYPEP X '(CONS (EQL FOO))) as a special case,
679 ;;; but hey at least this provides the IR2 support for it.
680 (define-vop (car-eq-if-listp)
681 (:args
(value :scs
(descriptor-reg))
682 (obj :scs
(immediate any-reg descriptor-reg
)))
683 (:temporary
(:sc unsigned-reg
) temp
)
686 (:translate car-eq-if-listp
)
688 (inst lea temp
(ea (- list-pointer-lowtag
) value
))
689 (inst test
:byte temp lowtag-mask
)
691 (inst cmp
:qword
(ea temp
) (encode-value-if-immediate obj
))
694 (eval-when (:compile-toplevel
) (aver (= sb-impl
::package-id-bits
16)))
695 (define-vop (keywordp symbolp
)
696 (:translate keywordp
)
698 (cond ((csubtypep (tn-ref-type args
) (specifier-type 'symbol
))
699 (inst cmp
:word
(ea (- 1 other-pointer-lowtag
) value
)
700 sb-impl
::+package-id-keyword
+))
702 (inst lea temp
(ea (- other-pointer-lowtag
) value
))
703 (inst test
:byte temp lowtag-mask
)
705 (inst mov
:dword temp
(ea temp
))
706 (inst shl
:dword temp
8) ; zeroize flag/generation bits
707 (inst cmp
:dword temp
708 (ash (logior (ash sb-impl
::+package-id-keyword
+ 8) symbol-widetag
) 8))))
711 (define-vop (consp type-predicate
)
714 (let ((is-not-cons-label (if not-p target DROP-THRU
)))
715 (inst cmp value nil-value
)
716 (inst jmp
:e is-not-cons-label
)
717 (test-type value temp target not-p
(list-pointer-lowtag)))
720 (define-vop (widetag=)
721 (:translate widetag
=)
723 (:args
(x :scs
(descriptor-reg)))
725 (:arg-types
* (:constant t
))
729 (inst cmp
:byte
(ea (- other-pointer-lowtag
) x
) widetag
)))
731 #+compact-instance-header
734 (:translate %instance-layout
)
736 (:args
(object :scs
(descriptor-reg)))
737 (:results
(res :scs
(descriptor-reg)))
738 (:variant-vars lowtag
)
739 (:variant instance-pointer-lowtag
)
741 (inst mov
:dword res
(ea (- 4 lowtag
) object
))))
743 (:translate %set-instance-layout
)
745 (:args
(object :scs
(descriptor-reg))
746 (value :scs
(any-reg descriptor-reg
)))
748 (:temporary
(:sc unsigned-reg
) temp
)
750 (emit-gengc-barrier object nil temp
(vop-nth-arg 1 vop
))
751 (inst mov
:dword
(ea (- 4 instance-pointer-lowtag
) object
) value
)))
752 (define-vop (%fun-layout %instance-layout
)
753 (:translate %fun-layout
)
754 (:variant fun-pointer-lowtag
))
755 (define-vop (%set-fun-layout %set-instance-layout
)
756 (:translate %set-fun-layout
)
758 (emit-gengc-barrier object nil temp
(vop-nth-arg 1 vop
))
759 (inst mov
:dword
(ea (- 4 fun-pointer-lowtag
) object
) value
)))
761 (:translate sb-c
::layout-eq
)
764 (:args
(object :scs
(descriptor-reg))
765 (layout :scs
(descriptor-reg immediate
)))
766 (:arg-types
* * (:constant t
))
769 (inst cmp
:dword
(ea (- 4 lowtag
) object
)
770 (if (sc-is layout immediate
)
771 (make-fixup (tn-value layout
) :layout
)
774 ;;; Return the DISP part of an EA based on MEM-OP,
775 ;;; which is a memory access vop such as INSTANCE-REF.
776 ;;; Return NIL if the access can't be absorbed into a following instruction.
777 (defun valid-memref-byte-disp (mem-op &aux
(info (vop-codegen-info mem-op
)))
778 (ecase (vop-name mem-op
)
779 (instance-index-ref-c
780 ;; for historical reasons, this has a "-C" variant which takes an info arg
781 (destructuring-bind (index) info
782 (- (ash (+ index instance-slots-offset
) word-shift
)
783 instance-pointer-lowtag
)))
784 ((%raw-instance-ref
/word %raw-instance-ref
/signed-word
)
785 ;; raw slot vops accept an immediate TN, not a codegen arg
786 (let ((index (tn-ref-tn (tn-ref-across (vop-args mem-op
)))))
787 (when (sc-is index immediate
)
788 (- (ash (+ (tn-value index
) instance-slots-offset
) word-shift
)
789 instance-pointer-lowtag
))))
791 (destructuring-bind (name index lowtag
) info
792 (declare (ignore name
))
793 (- (ash index word-shift
) lowtag
)))
794 (data-vector-ref-with-offset/simple-vector-c
795 (destructuring-bind (index offset
) info
796 (let ((disp (- (ash (+ vector-data-offset index offset
) word-shift
)
797 other-pointer-lowtag
)))
798 (if (typep disp
'(signed-byte 32)) disp
))))))
800 (define-vop (fixnump simple-type-predicate
)
803 (:args
(value :scs
(any-reg descriptor-reg
)))
805 ;; the compiler is very sensitive to this cost here as regards boxing. DON'T TOUCH !!!
807 (awhen (tn-ref-memory-access arg-ref
)
808 (setq value
(ea (cdr it
) value
)))
809 (generate-fixnum-test value
)))
812 ((define-simple-array-type-vops ()
815 (lambda (saetp &aux
(primtype (saetp-primitive-type-name saetp
))
816 (name (symbolicate primtype
"-P")))
817 `(define-vop (,name symbolp
)
820 (test-other-ptr value args
,(saetp-typecode saetp
) temp out
)
822 *specialized-array-element-type-properties
*))))
823 (define-simple-array-type-vops))
825 ;;; Try to absorb a memory load into FIXNUMP.
826 (defoptimizer (sb-c::vop-optimize fixnump
) (vop)
827 ;; Ensure that the fixnump vop does not try to absorb more than one memref.
828 ;; That is, if the initial IR2 matches (fixnump (memref (memref))) which is simplified
829 ;; to (memref+fixnump (memref x)), it would seem to allow matching of the pattern
830 ;; again if this optimizer is reapplied, because the "new" fixnump vop is superficially
831 ;; the same, except for the attachment of extra data to its input.
832 (unless (tn-ref-memory-access (vop-args vop
))
833 (let ((prev (sb-c::previous-vop-is
835 '(instance-index-ref-c slot
836 ;; FIXME: could we also handle the non "-C" vop?
837 ;; The problem is that because FIXNUMP only takes one arg,
838 ;; an additional TN would have to be grafted into the data flow
839 ;; to convey the INDEX arg. So it's not the same fixnump vop
840 ;; any more - it's like a two-arg variant of fixnump.
841 data-vector-ref-with-offset
/simple-vector-c
))))
842 ;; Inhibit the optimization on simple-vector if we need to trap uninitialized reads.
843 ;; #+ubsan always inhibits, otherwise it's policy-based
845 (eq (vop-name prev
) 'data-vector-ref-with-offset
/simple-vector-c
)
846 #-ubsan
(sb-c::policy
(sb-c::vop-node vop
) (= safety
3)))
847 (return-from vop-optimize-fixnump-optimizer nil
))
848 (aver (not (vop-results vop
))) ; is a :CONDITIONAL vop
849 (when (and prev
(eq (vop-block prev
) (vop-block vop
)))
850 (let ((arg (vop-args vop
)))
851 (when (and (eq (tn-ref-tn (vop-results prev
)) (tn-ref-tn arg
))
852 (sb-c::very-temporary-p
(tn-ref-tn arg
)))
853 (binding* ((disp (valid-memref-byte-disp prev
) :exit-if-null
)
855 (sb-c:reference-tn
(tn-ref-tn (vop-args prev
)) nil
))
856 (new (sb-c::emit-and-insert-vop
857 (sb-c::vop-node vop
) (vop-block vop
) (sb-c::vop-info vop
)
858 arg-ref nil prev
(vop-codegen-info vop
))))
859 (setf (tn-ref-memory-access arg-ref
) `(:read .
,disp
))
860 (sb-c::delete-vop prev
)
861 (sb-c::delete-vop vop
)
864 (define-vop (>-integer-fixnum
)
866 (:args
(integer :scs
(descriptor-reg))
867 (fixnum :scs
(immediate any-reg
)))
868 (:arg-types
(:or integer bignum
) tagged-num
)
869 (:temporary
(:sc unsigned-reg
) temp
)
872 (:arg-refs integer-ref
)
874 (:variant-vars comparison
)
877 (let* ((integer-p (csubtypep (tn-ref-type integer-ref
) (specifier-type 'integer
)))
878 (fixnum (if (sc-is fixnum immediate
)
879 (let* ((value (fixnumize (tn-value fixnum
)))
881 (cond ((plausible-signed-imm32-operand-p value
)
883 ((and (plausible-signed-imm32-operand-p (+ value one
))
884 (or (and (eql comparison
:le
)
885 (setf comparison
:l
))
886 (and (eql comparison
:g
)
887 (setf comparison
:ge
))))
888 (setf value
(+ value one
)))
889 ((and (plausible-signed-imm32-operand-p (- value one
))
890 (or (and (eql comparison
:ge
)
891 (setf comparison
:g
))
892 (and (eql comparison
:l
)
893 (setf comparison
:le
))))
894 (setf value
(- value one
)))
896 (inst mov temp value
)
899 (multiple-value-bind (yep nope
)
901 (values not-target target
)
902 (values target not-target
))
904 (when (types-equal-or-intersect (tn-ref-type integer-ref
) (specifier-type 'fixnum
))
905 (generate-fixnum-test integer
)
908 (memq comparison
'(:ge
:l
))
909 (csubtypep (type-intersection (tn-ref-type integer-ref
)
910 (specifier-type 'fixnum
))
911 (specifier-type '(integer * -
1))))
912 (inst jmp
:z
(if (eq comparison
:l
)
916 (memq comparison
'(:ge
:l
))
917 (csubtypep (type-intersection (tn-ref-type integer-ref
)
918 (specifier-type 'fixnum
))
919 (specifier-type '(integer 0))))
920 (inst jmp
:z
(if (eq comparison
:l
)
924 (inst jmp
:nz BIGNUM
)
925 (cond ((eql fixnum
0)
926 (inst test integer integer
))
927 ((or (and (eql fixnum
#.
(fixnumize -
1))
928 (or (and (eql comparison
:le
)
929 (setf comparison
:l
))
930 (and (eql comparison
:g
)
931 (setf comparison
:ge
))))
932 (and (eql fixnum
#.
(fixnumize 1))
933 (or (and (eql comparison
:ge
)
934 (setf comparison
:g
))
935 (and (eql comparison
:l
)
936 (setf comparison
:le
)))))
937 (inst test integer integer
))
939 (inst cmp integer fixnum
)))
940 (inst jmp comparison yep
)
943 (unless (fixnum-or-other-pointer-tn-ref-p integer-ref t
)
944 (test-type integer temp nope t
(other-pointer-lowtag)))
945 (loadw temp integer
0 other-pointer-lowtag
)
947 (inst cmp
:byte temp bignum-widetag
)
949 #.
(assert (= (integer-length bignum-widetag
) 5))
951 (inst cmp
:dword
(ea (+ (- other-pointer-lowtag
) (/ n-word-bytes
2)) integer temp
) 0)
952 (inst jmp
(case comparison
953 ((:l
:le
) (if not-p
:ge
:l
))
954 (t (if not-p
:l
:ge
)))
958 (define-vop (<-integer-fixnum
>-integer-fixnum
)
962 (define-vop (>-fixnum-integer
>-integer-fixnum
)
964 (:args
(fixnum :scs
(immediate any-reg
))
965 (integer :scs
(descriptor-reg)))
966 (:arg-types tagged-num
(:or integer bignum
))
967 (:arg-refs nil integer-ref
)
970 (define-vop (<-fixnum-integer
>-fixnum-integer
)
975 (define-vop (<=-integer-fixnum
>-integer-fixnum
)
978 (define-vop (>=-integer-fixnum
<-integer-fixnum
)
981 (define-vop (<=-fixnum-integer
>-fixnum-integer
)
984 (define-vop (>=-fixnum-integer
<-fixnum-integer
)
988 (define-vop (load-other-pointer-widetag)
989 (:args
(value :scs
(any-reg descriptor-reg
)))
990 (:arg-refs value-ref
)
991 (:info not-other-pointer-label null-label zero-extend
)
992 (:results
(r :scs
(unsigned-reg)))
993 (:result-types unsigned-num
)
996 (if (types-equal-or-intersect
997 (type-difference (tn-ref-type value-ref
) (specifier-type 'null
))
998 (specifier-type 'cons
))
999 (inst cmp value nil-value
)
1000 (inst cmp
:byte value
(logand nil-value
#xff
)))
1001 (inst jmp
:e null-label
))
1002 (cond ((other-pointer-tn-ref-p value-ref t
)
1004 (inst movzx
'(:byte
:dword
) r
(ea (- other-pointer-lowtag
) value
))
1005 (inst mov
:byte r
(ea (- other-pointer-lowtag
) value
))))
1007 (%lea-for-lowtag-test r value other-pointer-lowtag
:qword
)
1008 (inst test
:byte r lowtag-mask
)
1009 (inst jmp
:nz not-other-pointer-label
)
1011 (inst movzx
'(:byte
:dword
) r
(ea r
))
1012 (inst mov
:byte r
(ea r
)))))))
1014 (define-vop (test-widetag)
1015 (:args
(value :scs
(unsigned-reg) :target temp
))
1016 (:temporary
(:sc unsigned-reg
:from
(:argument
1)) temp
)
1017 (:info target not-p type-codes
)
1019 (move temp value
:dword
)
1020 (%test-headers nil temp target not-p nil
1021 (if (every #'integerp type-codes
)
1022 (canonicalize-widetags type-codes
)
1024 :load-widetag nil
)))
1026 (macrolet ((read-depthoid ()
1027 `(ea (- (+ 4 (ash (+ instance-slots-offset
1028 (get-dsd-index layout sb-kernel
::flags
))
1030 instance-pointer-lowtag
)
1033 (:translate layout-depthoid
)
1034 (:policy
:fast-safe
)
1035 (:args
(layout :scs
(descriptor-reg)))
1036 (:results
(res :scs
(any-reg)))
1037 (:result-types fixnum
)
1039 (inst movsx
'(:dword
:qword
) res
(read-depthoid))))
1041 (:translate sb-c
::layout-depthoid-ge
)
1042 (:policy
:fast-safe
)
1043 (:args
(layout :scs
(descriptor-reg)))
1045 (:arg-types
* (:constant
(unsigned-byte 16)))
1048 (inst cmp
:dword
(read-depthoid) (fixnumize k
))))
1050 (defun structure-is-a (layout test-layout
&optional target not-p done
)
1051 (cond ((integerp test-layout
)
1053 (if (typep test-layout
'(unsigned-byte 8))
1056 (ea (- (ash (+ instance-slots-offset
1057 (get-dsd-index layout sb-kernel
::flags
))
1059 instance-pointer-lowtag
)
1062 ((let ((classoid (layout-classoid test-layout
)))
1063 (and (eq (classoid-state classoid
) :sealed
)
1064 (not (classoid-subclasses classoid
))))
1065 (emit-constant test-layout
)
1066 #+compact-instance-header
1068 layout
(make-fixup test-layout
:layout
))
1069 #-compact-instance-header
1070 (inst cmp
(emit-constant test-layout
) layout
))
1073 (let* ((depthoid (layout-depthoid test-layout
))
1074 (offset (+ (id-bits-offset)
1075 (ash (- depthoid
2) 2)
1076 (- instance-pointer-lowtag
))))
1078 (> depthoid sb-kernel
::layout-id-vector-fixed-capacity
))
1079 (inst cmp
:dword
(read-depthoid) (fixnumize depthoid
))
1080 (inst jmp
:l
(if not-p target done
)))
1083 ;; Small layout-ids can only occur for layouts made in genesis.
1084 ;; Therefore if the compile-time value of the ID is small,
1085 ;; it is permanently assigned to that type.
1086 ;; Otherwise, we allow for the possibility that the compile-time ID
1087 ;; is not the same as the load-time ID.
1088 ;; I don't think layout-id 0 can get here, but be sure to exclude it.
1089 (cond ((or (typep (layout-id test-layout
) '(and (signed-byte 8) (not (eql 0))))
1090 (not (sb-c::producing-fasl-file
)))
1091 (layout-id test-layout
))
1093 (make-fixup test-layout
:layout-id
)))))))))
1096 (:translate sb-c
::%structure-is-a
)
1097 (:args
(x :scs
(descriptor-reg)))
1098 (:arg-types
* (:constant t
))
1100 (:policy
:fast-safe
)
1103 (structure-is-a x test
)))
1106 (:translate sb-c
::structure-typep
)
1107 (:args
(object :scs
(descriptor-reg)))
1108 (:arg-types
* (:constant t
))
1110 (:policy
:fast-safe
)
1112 (:info target not-p test-layout
)
1113 (:temporary
(:sc descriptor-reg
) layout
)
1115 (unless (instance-tn-ref-p args
)
1116 (%test-lowtag object layout
(if not-p target done
) t instance-pointer-lowtag
))
1118 (cond ((and (not (integerp test-layout
))
1119 (let ((classoid (layout-classoid test-layout
)))
1120 (and (eq (classoid-state classoid
) :sealed
)
1121 (not (classoid-subclasses classoid
)))))
1122 (emit-constant test-layout
)
1123 #+compact-instance-header
1124 (inst cmp
:dword
(ea (- 4 instance-pointer-lowtag
) object
)
1125 (make-fixup test-layout
:layout
))
1126 #-compact-instance-header
1128 (inst mov layout
(emit-constant test-layout
))
1129 (inst cmp
(object-slot-ea object instance-slots-offset instance-pointer-lowtag
)
1132 #+compact-instance-header
1133 (inst mov
:dword layout
(ea (- 4 instance-pointer-lowtag
) object
))
1134 #-compact-instance-header
1135 (loadw layout object instance-slots-offset instance-pointer-lowtag
)
1136 (structure-is-a layout test-layout target not-p done
)))
1137 (inst jmp
(if (if (integerp test-layout
)
1143 (define-vop (structure-typep*)
1144 (:args
(layout :scs
(descriptor-reg)))
1145 (:arg-types
* (:constant t
))
1146 (:policy
:fast-safe
)
1147 (:info target not-p test-layout
)
1149 (structure-is-a layout test-layout target not-p done
)
1150 (inst jmp
(if (if (integerp test-layout
)
1156 (define-vop (load-instance-layout)
1157 (:args
(object :scs
(any-reg descriptor-reg
)))
1159 (:info not-instance
)
1160 (:temporary
(:sc unsigned-reg
) temp
)
1161 (:results
(r :scs
(descriptor-reg)))
1163 (unless (instance-tn-ref-p args
)
1164 (%test-lowtag object temp not-instance t instance-pointer-lowtag
))
1165 #+compact-instance-header
1166 (inst mov
:dword r
(ea (- 4 instance-pointer-lowtag
) object
))
1167 #-compact-instance-header
1168 (loadw r object instance-slots-offset instance-pointer-lowtag
)))