mirror of
git://git.code.sf.net/p/sbcl/sbcl
synced 2026-09-10 07:26:40 -04:00
1558 lines
67 KiB
Common Lisp
1558 lines
67 KiB
Common Lisp
;;;; This software is part of the SBCL system. See the README file for
|
|
;;;; more information.
|
|
;;;;
|
|
;;;; While most of SBCL is derived from the CMU CL system, the test
|
|
;;;; files (like this one) were written from scratch after the fork
|
|
;;;; from CMU CL.
|
|
;;;;
|
|
;;;; This software is in the public domain and is provided with
|
|
;;;; absolutely no warranty. See the COPYING and CREDITS files for
|
|
;;;; more information.
|
|
|
|
#-x86-64 (invoke-restart 'run-tests::skip-file)
|
|
|
|
(load "compiler-test-util.lisp")
|
|
(import 'ctu:disassembly-lines)
|
|
|
|
(with-test (:name :lowtag-test-elision :broken-on :sbcl)
|
|
;; This tests a certain behavior that while "undefined" should at least not
|
|
;; be fatal. This is important for things like hash-table :TEST where we might
|
|
;; call (EQUAL x y) with X being an unbound marker indicating an empty cell.
|
|
;; After we started using IR1 type derivation to elide lowtag as a guard condition
|
|
;; in some type tests, it became more likely to dereference an unbound marker
|
|
;; which does not fit anywhere in the lisp type space.
|
|
(let ((f (compile nil
|
|
'(lambda (x)
|
|
(typecase x
|
|
((or character number list sb-kernel:instance function)
|
|
nil)
|
|
;; After eliminating the preceding cases, the compiler knows
|
|
;; that the only remaining pointer type is OTHER-POINTER,
|
|
;; so it just tries to read the widetag.
|
|
;; If X is the unbound marker, this will read a byte preceding
|
|
;; the start of static space, but it holds a zero.
|
|
(simple-vector 2))))))
|
|
(assert (not (funcall f (sb-kernel:make-unbound-marker))))))
|
|
|
|
(with-test (:name :lowtag-test-elision.2)
|
|
(let ((ubm (opaque-identity (sb-kernel:make-unbound-marker)))
|
|
(thing (opaque-identity "")))
|
|
(assert (not (eql thing ubm)))
|
|
(assert (not (equal thing ubm)))
|
|
(assert (not (equalp thing ubm)))
|
|
(assert (not (eql ubm thing)))
|
|
(assert (not (equal ubm thing)))
|
|
(assert (not (equalp ubm thing)))))
|
|
|
|
(sb-vm::define-vop (tryme)
|
|
(:generator 1 (sb-assem:inst mov :byte (sb-vm::ea :gs sb-vm::rax-tn) 0)))
|
|
(with-test (:name :try-gs-segment)
|
|
(assert (loop for line in (disassembly-lines
|
|
(compile nil
|
|
'(lambda () (sb-sys:%primitive tryme))))
|
|
thereis (search "MOV BYTE PTR GS:[RAX]" line))))
|
|
|
|
(defun strip-assem-junk (fun &optional (remove-epilogue t))
|
|
(let ((lines (disassembly-lines (compile nil fun))))
|
|
;; For human-readability, kill the whitespace
|
|
(setq lines (mapcar (lambda (x) (string-left-trim " ;" x)) lines))
|
|
(when (string= (car (last lines)) "")
|
|
(setq lines (nbutlast lines)))
|
|
;; Remove safepoint traps
|
|
(setq lines (remove-if (lambda (x) (search "; safepoint" x)) lines))
|
|
;; If the last 3 lines are of the expected form
|
|
;; LEAVE / CLC / RET
|
|
;; then strip them out
|
|
(if (and remove-epilogue
|
|
(let ((last3 (subseq lines (- (length lines) 3))))
|
|
(and (search "LEAVE" (first last3))
|
|
(search "CLC" (second last3))
|
|
(search "RET" (third last3)))))
|
|
(butlast lines 3)
|
|
lines)))
|
|
(defun disasm-load (safety symbol)
|
|
;; This lambda has a name because if it doesn't, then the name
|
|
;; is something stupid like (lambda () in ...) which pretty-prints
|
|
;; on a random number of lines.
|
|
(strip-assem-junk `(sb-int:named-lambda test ()
|
|
(declare (optimize (debug 0) (safety ,safety)
|
|
(sb-c:verify-arg-count 0)))
|
|
,symbol)))
|
|
(defun disasm-store (sexpr)
|
|
(strip-assem-junk `(sb-int:named-lambda test (x)
|
|
(declare (ignorable x))
|
|
(declare (optimize (debug 0)
|
|
(sb-c:verify-arg-count 0)))
|
|
,sexpr)))
|
|
|
|
(with-test (:name :symeval-known-thread-local
|
|
:skipped-on (not :sb-thread))
|
|
;; It should take 1 instruction to read a known thread-local var
|
|
(assert (= (length (disasm-load 1 'sb-thread:*current-thread*)) 1))
|
|
(assert (= (length (disasm-load 1 'sb-sys:*interrupt-pending*)) 1))
|
|
(assert (= (length (disasm-load 1 'sb-kernel:*gc-inhibit*)) 1))
|
|
(assert (= (length (disasm-load 1 'sb-kernel:*restart-clusters*)) 1))
|
|
(assert (= (length (disasm-load 1 'sb-kernel:*handler-clusters*)) 1)))
|
|
|
|
(with-test (:name :set-known-thread-local :skipped-on (or (not :immobile-space)
|
|
(not :sb-thread)))
|
|
;; It should take 1 instruction to write a known thread-local var
|
|
(assert (= (length (disasm-store '(setq sb-kernel:*gc-inhibit* x))) 1)))
|
|
|
|
;; Lack of earmuffs on this symbol allocates it in dynamic space
|
|
(defvar foo)
|
|
#-immobile-symbols (assert (not (sb-kernel:immobile-space-obj-p 'foo)))
|
|
;; This compilation causes a side-effect of assigning FOO a TLS index
|
|
;; DO NOT REMOVE!
|
|
(compile nil '(lambda (foo) (eval 'frob)))
|
|
|
|
(with-test (:name :symeval-known-tls-index
|
|
:skipped-on (or (not :immobile-space) :immobile-symbols
|
|
(not :sb-thread)))
|
|
;; When symbol SC is IMMEDIATE:
|
|
;; 498B9578210000 MOV RDX, [R13+disp] ; tls: *PRINT-BASE*
|
|
;; 83FA61 CMP EDX, 97
|
|
;; 480F44142538F94B20 CMOVEQ RDX, [#x204BF938] ; *PRINT-BASE*
|
|
;; (TODO: could use "CMOVEQ RDX, [RIP-n]" in immobile code)
|
|
(let ((text (disasm-load 0 '*print-base*)))
|
|
#+tls-load-indirect (assert (= (length text) 2)) ; number of lines
|
|
#-tls-load-indirect (progn
|
|
(assert (= (length text) 3)) ; number of lines
|
|
;; two lines should be annotated with *PRINT-BASE*
|
|
(assert (= (loop for line in text count (search "*PRINT-BASE*" line)) 2))))
|
|
|
|
;; When symbol SC is CONSTANT:
|
|
;; 498B9578290000 MOV RDX, [R13+disp] ; tls: FOO
|
|
;; 488B059EFFFFFF MOV RAX, [RIP-98] ; 'FOO
|
|
;; 83FA61 CMP EDX, 97
|
|
;; 480F4450F9 CMOVEQ RDX, [RAX-7]
|
|
(let ((text (disasm-load 0 'foo)))
|
|
#+tls-load-indirect (assert (= (length text) 2)) ; number of lines
|
|
#-tls-load-indirect (progn
|
|
(assert (= (length text) 4))
|
|
;; two lines should be annotated with FOO
|
|
(assert (= (loop for line in text count (search "FOO" line)) 2)))))
|
|
|
|
(defvar *blub*) ; immobile space
|
|
(defvar blub) ; dynamic space
|
|
#+immobile-space (assert (sb-kernel:immobile-space-obj-p '*blub*))
|
|
#-immobile-symbols (assert (not (sb-kernel:immobile-space-obj-p 'blub)))
|
|
|
|
(with-test (:name :symeval-unknown-tls-index
|
|
:skipped-on (or (not :immobile-space) :immobile-symbols
|
|
(not :sb-thread)))
|
|
;; When symbol SC is immediate:
|
|
;; 8B142514A24C20 MOV EDX, [#x204CA214] ; tls_index: *BLUB*
|
|
;; 4A8B142A MOV RDX, [RDX+R13]
|
|
;; 83FA61 CMP EDX, 97
|
|
;; 480F44142518A24C20 CMOVEQ RDX, [#x204CA218] ; *BLUB*
|
|
;; (TODO: could use "CMOVEQ RDX, [RIP-n]" in immobile code)
|
|
(let ((text (disasm-load 0 '*blub*)))
|
|
(assert (= (length text) 4))
|
|
;; two lines should be annotated with *BLUB*
|
|
(assert (= (loop for line in text count (search "*BLUB*" line)) 2)))
|
|
|
|
;; When symbol SC is constant:
|
|
;; 488B05B3FFFFFF MOV RAX, [RIP-77] ; 'BLUB"
|
|
;; 8B50F5 MOV EDX, [RAX-11]
|
|
;; 4A8B142A MOV RDX, [RDX+R13]
|
|
;; 83FA61 CMP EDX, 97
|
|
;; 480F4450F9 CMOVEQ RDX, [RAX-7]
|
|
(assert (= (length (disasm-load 0 'blub)) 5)))
|
|
|
|
(with-test (:name :object-not-type-error-encoding)
|
|
;; There should not be a "MOV Rnn, #xSYMBOL" instruction
|
|
;; before the OBJECT-NOT-TYPE-ERROR.
|
|
(let* ((lines
|
|
(split-string
|
|
(with-output-to-string (s)
|
|
(let ((sb-disassem:*disassem-location-column-width* 0))
|
|
(disassemble '(lambda (x) (the sb-assem:label x))
|
|
:stream s)))
|
|
#\newline))
|
|
(index
|
|
(position "OBJECT-NOT-TYPE-ERROR" lines :test 'search)))
|
|
(let ((line (nth (+ index 2) lines)))
|
|
(assert (search "; #<SB-KERNEL:LAYOUT " line))
|
|
(assert (search " SB-ASSEM:LABEL" line)))))
|
|
|
|
(with-test (:name :c-call :skipped-on :win32)
|
|
(let* ((lines (split-string
|
|
(with-output-to-string (s)
|
|
(let ((sb-disassem:*disassem-location-column-width* 0))
|
|
(disassemble 'sb-sys:deallocate-system-memory :stream s)))
|
|
#\newline))
|
|
(c-call (find "os_deallocate" lines :test #'search)))
|
|
;; Depending on #+immobile-code it's either direct or memory indirect.
|
|
#+immobile-code (assert (search "CALL #x" c-call))
|
|
#-immobile-code (assert (search "LEA RBX, [R12-" c-call))))
|
|
|
|
(with-test (:name :set-symbol-value-imm)
|
|
(let (success)
|
|
(dolist (line (split-string
|
|
(with-output-to-string (s)
|
|
(let ((sb-disassem:*disassem-location-column-width* 0))
|
|
(disassemble '(lambda () (setq *print-base* 8)) :stream s)))
|
|
#\newline))
|
|
(when (and #+sb-thread (search "MOV QWORD PTR [R" line)
|
|
#-sb-thread (search "MOV QWORD PTR [" line)
|
|
(search (format nil ", ~D" (ash 8 sb-vm:n-fixnum-tag-bits)) line))
|
|
(setq success t)))
|
|
(assert success)))
|
|
|
|
(defglobal *avar* nil)
|
|
(with-test (:name :set-symbol-value-imm-2
|
|
:skipped-on (not :immobile-space))
|
|
(let (success)
|
|
(dolist (line (split-string
|
|
(with-output-to-string (s)
|
|
(let ((sb-disassem:*disassem-location-column-width* 0))
|
|
(disassemble '(lambda () (setq *avar* :downcase)) :stream s)))
|
|
#\newline))
|
|
;; Should have an absolute mem ref and an immediate operand:
|
|
;; 48C7042568904B207F723A20 MOV QWORD PTR [#x204B9068], #x203A727F
|
|
(when (and (search "MOV QWORD PTR [#x" line)
|
|
(search "], #x" line))
|
|
(setq success t)))
|
|
(assert success)))
|
|
|
|
(defun test-arith-op-codegen (fun imm)
|
|
(split-string
|
|
(with-output-to-string (s)
|
|
(let ((sb-disassem:*disassem-location-column-width* 0))
|
|
(disassemble `(lambda (a b)
|
|
(declare (fixnum b))
|
|
(print 1) ; force spilling args to stack
|
|
;; Use an expression that doesn't select CMOV
|
|
;; as the implementation.
|
|
;; CMOV thinks it needs all args loaded,
|
|
;; defeating the purpose of this test.
|
|
(values a (if (,fun b ,imm) 'baz (print 2))))
|
|
:stream s)))
|
|
#\newline))
|
|
|
|
(with-test (:name :test-high-byte-reg)
|
|
;; Assert two things:
|
|
;; - that LOGBITP can use a high byte register (sometimes)
|
|
;; - that the fixnum #x80 (representation #x100) is a single byte test
|
|
(let (success)
|
|
(dolist (line
|
|
(split-string
|
|
(with-output-to-string (s)
|
|
(let ((sb-disassem:*disassem-location-column-width* 0))
|
|
(disassemble '(lambda (x)
|
|
(let ((q (the fixnum (truncate (the fixnum x) 3)))) (logtest q #x80)))
|
|
:stream s)))
|
|
#\newline))
|
|
(when (search "TEST AH, 1" line)
|
|
(setq success t)))
|
|
(assert success)))
|
|
|
|
(with-test (:name :test-byte-stack-imm)
|
|
;; Assert that LOGBITP can accept memory + immediate as the operands
|
|
(let (success)
|
|
(dolist (line (test-arith-op-codegen 'logtest #x80))
|
|
(when (and (search "TEST BYTE PTR [RBP-" line)
|
|
(search (format nil
|
|
", ~d"
|
|
(ash (ash #x80 sb-vm:n-fixnum-tag-bits) -8))
|
|
line))
|
|
(setq success t)))
|
|
(assert success)))
|
|
|
|
(with-test (:name :fixnum-cmp-stack-imm)
|
|
;; Assert that < can accept memory + immediate as the operands
|
|
(let (success)
|
|
(dolist (line (test-arith-op-codegen '< -5))
|
|
(when (and (search "CMP QWORD PTR [RBP-" line)
|
|
(search (format nil
|
|
", ~d" (ash -5 sb-vm:n-fixnum-tag-bits))
|
|
line))
|
|
(setq success t)))
|
|
(assert success)))
|
|
|
|
(with-test (:name :list-vop-immediate-to-mem
|
|
:skipped-on (not :immobile-space))
|
|
(let ((lines
|
|
(split-string
|
|
(with-output-to-string (s)
|
|
(let ((sb-disassem:*disassem-location-column-width* 0))
|
|
(disassemble '(lambda () (list :key :test)) :stream s)))
|
|
#\newline)))
|
|
(assert (loop for line in lines
|
|
thereis (and (search "MOV QWORD PTR [" line)
|
|
(search ":KEY" line))))))
|
|
|
|
(defstruct thing x)
|
|
(with-test (:name :instance-ref-eq
|
|
:skipped-on (not :immobile-space))
|
|
(let ((lines
|
|
(split-string
|
|
(with-output-to-string (s)
|
|
(disassemble '(lambda (obj)
|
|
(if (eq (thing-x (truly-the thing obj)) :yup) 1 2))
|
|
:stream s))
|
|
#\newline)))
|
|
;; assert that the comparison instruction performed the memory load
|
|
(assert (loop for line in lines
|
|
thereis
|
|
(and (search "CMP QWORD PTR [" line)
|
|
(search ":YUP" line))))))
|
|
|
|
(defun thing-ref-thing-ref (arg1 arg2)
|
|
(declare (optimize (safety 0)))
|
|
(let ((answer (typep (thing-x (thing-x arg1)) 'fixnum)))
|
|
(frobify arg1 arg2)
|
|
answer))
|
|
(defun frobify (a b) (values a b))
|
|
(compile 'thing-ref-thing-ref)
|
|
|
|
(with-test (:name :fixnump-thing-ref)
|
|
(flet ((try (access-form true false)
|
|
(let* ((f (compile nil `(lambda (obj) (typep ,access-form 'fixnum))))
|
|
(lines
|
|
(split-string
|
|
(with-output-to-string (s) (disassemble f :stream s))
|
|
#\newline)))
|
|
(assert (funcall f true))
|
|
(assert (not (funcall f false)))
|
|
;; assert that the TEST instruction dereferenced OBJ and performed the test
|
|
(assert (loop for line in lines
|
|
thereis
|
|
(and (search "TEST BYTE PTR [" line)
|
|
(search (format nil ", ~D" sb-vm:fixnum-tag-mask)
|
|
line)))))))
|
|
(try '(thing-x (truly-the thing obj))
|
|
(make-thing :x 1) (make-thing :x "hi"))
|
|
(try '(car obj) '(1) '("hi"))
|
|
(try '(cdr obj) '("hi" . 1) '("hi")))
|
|
;; fixnump of memref of memref was eliding one memref by accident
|
|
(assert (thing-ref-thing-ref (make-thing :x (make-thing :x 3)) 'foo)))
|
|
|
|
(with-test (:name :huge-code :skipped-on (not :immobile-code))
|
|
(sb-vm::allocate-code-object :immobile 4 (* 2 1024 1024)))
|
|
|
|
(defun bbb (x y z)
|
|
;; I don't want the number of expected comparisons to depend on whether
|
|
;; the code gets disassembled with versus without the initial segment.
|
|
(declare (optimize (sb-c:verify-arg-count 0)))
|
|
(if x
|
|
(ecase y
|
|
(-2 'a) (2 'b) (3 'c) (4 (error "no")) (5 'd) (6 'e) (7 'wat) (8 '*) (9 :hi))
|
|
(case z
|
|
(#\a :a) (#\b :b) (#\e :c) (#\f (print :d)) (#\g :e) (#\h :f) (t nil))))
|
|
|
|
(defun try-case-known-fixnum (x)
|
|
(declare (optimize (sb-c:verify-arg-count 0)))
|
|
(case (the fixnum x)
|
|
(0 :a) (1 :b) (2 :c) (5 (print :d)) (6 :c) (-1 :blah)))
|
|
(defun try-case-maybe-fixnum (x)
|
|
(when (typep x 'fixnum)
|
|
(case x
|
|
(0 :a) (1 :b) (2 :c) (5 :d) (6 (print :c)) (-1 :blah))))
|
|
|
|
(defun try-case-known-char (x)
|
|
(declare (optimize (sb-c:verify-arg-count 0)))
|
|
(case (the character x)
|
|
(#\a :a) (#\b :b)(#\c :c) (#\d :d) (#\e (print :e)) (#\f :b)))
|
|
(defun try-case-maybe-char (x)
|
|
(declare (optimize (sb-c:verify-arg-count 0)))
|
|
(when (characterp x)
|
|
(case x (#\a :a) (#\b :b)(#\c :c) (#\d :d) (#\e :e) (#\f (print :a)))))
|
|
|
|
(defun expect-n-comparisons (fun-name howmany)
|
|
(let ((lines
|
|
(split-string
|
|
(with-output-to-string (s) (disassemble fun-name :stream s))
|
|
#\newline)))
|
|
(assert (= (loop for line in lines count (search "CMP" line))
|
|
howmany))))
|
|
|
|
(with-test (:name :multiway-branch-generic-eq)
|
|
;; there's 1 test of NIL, 1 test of character-widetag, and 2 limit checks
|
|
;; and 1 for comparing the key
|
|
(expect-n-comparisons 'bbb 4)
|
|
(loop for ((x y z) . expect) in '(((t 3 nil) . c)
|
|
((t 9 nil) . :hi)
|
|
((nil nil #\b) . :b)
|
|
((nil nil #\x) . nil))
|
|
do (assert (eq (bbb x y z) expect))))
|
|
|
|
(with-test (:name :multiway-branch-fixnum-eq)
|
|
(expect-n-comparisons 'try-case-known-fixnum 1) ; just the upper bound
|
|
(expect-n-comparisons 'try-case-maybe-fixnum 1))
|
|
|
|
(with-test (:name :multiway-branch-char-eq)
|
|
(expect-n-comparisons 'try-case-known-char 2) ; widetag test and upper bound
|
|
(expect-n-comparisons 'try-case-maybe-char 2))
|
|
|
|
(with-test (:name :multiway-branch-min-branch-factor)
|
|
;; Test that multiway vop shows up in IR2
|
|
(let ((s (with-output-to-string (sb-c::*compiler-trace-output*)
|
|
(checked-compile '(lambda (b)
|
|
(case b
|
|
((0) :a) ((0) :b) ((0) :c) ((1) :d)
|
|
((2) :e) ((3) (print :f))))
|
|
:allow-style-warnings t))))
|
|
(assert (search "JUMP-TABLE" s)))
|
|
;; There are too few cases after duplicate removal to be considered multiway
|
|
(let ((s (with-output-to-string (sb-c::*compiler-trace-output*)
|
|
(checked-compile '(lambda (b) (case b ((0) :a) ((0) :b) ((0) :c) ((1) (print :d))))
|
|
:allow-style-warnings t))))
|
|
(assert (not (search "JUMP-TABLE" s)))))
|
|
|
|
;;; Don't crash on large constants
|
|
;;; https://bugs.launchpad.net/sbcl/+bug/1850701
|
|
;;; (modified example to avoid style warning)
|
|
(with-test (:name :multiway-branch-large-constants)
|
|
(let ((f (checked-compile
|
|
'(lambda (p)
|
|
(case p
|
|
(1881481965704634 0)
|
|
(1881481965704630 1)
|
|
(1881481965704635 2)
|
|
(1881481965704629 3)
|
|
(1881481965704633 4)
|
|
(t nil))))))
|
|
(assert (eql (funcall f 1881481965704629) 3))))
|
|
|
|
;; https://bugs.launchpad.net/sbcl/+bug/1850705
|
|
(with-test (:name :multiway-branch-dead-code-elim)
|
|
(let ((f (checked-compile
|
|
'(lambda (b)
|
|
(case b
|
|
((4 1 2 3) 0)
|
|
((2 4) (mod b (min -49 0)))
|
|
(t 0)))
|
|
:allow-style-warnings t)))
|
|
(dotimes (i 5) (assert (eql (funcall f i) 0)))
|
|
(assert (eql (funcall f 'anything) 0)))
|
|
(let ((f (checked-compile
|
|
'(lambda (s1 s2 c)
|
|
(case s2
|
|
((2) s2)
|
|
((2) (mod s1 (max 9 0)))
|
|
((1 4) 0)
|
|
((-1) c)
|
|
(t 0)))
|
|
:allow-style-warnings t)))
|
|
(assert (eql (funcall f nil 2 nil) 2))
|
|
(assert (eql (funcall f 0 -1 :hi) :hi))))
|
|
|
|
;; https://bugs.launchpad.net/sbcl/+bug/1850785
|
|
(with-test (:name :multiway-branch-to-branch)
|
|
;; The behavior changes because of single-use var elimination
|
|
;; which eliminates a move which eliminates a vop as a no-op,
|
|
;; or something, which left an empty block. (Hand-waving explanation)
|
|
(let* ((form '(case c
|
|
((6) c)
|
|
((9 13 12) (case a ((-2589) a) ((970) 0) (t b)))
|
|
(t a)))
|
|
(l1 `(lambda (a b c) (declare (optimize (debug 0))) ,form))
|
|
(l2 `(lambda (a b c) ,form))
|
|
(f1 (checked-compile l1))
|
|
(f2 (checked-compile l2))
|
|
(vals '(:good :bad 0)))
|
|
(assert (eq (apply f1 vals) :good))
|
|
(assert (eq (apply f2 vals) :good)))
|
|
;;
|
|
(let* ((form '(case d
|
|
((7 18) (case b
|
|
((114361) :bad)
|
|
((77773) a)
|
|
((118772) c)
|
|
(t :bad)))
|
|
((6) 2)
|
|
((3) b)
|
|
((15 21 9 19 2) 3)
|
|
((20) 1)
|
|
(t a)))
|
|
(vals '(:good 5 :xyz 0))
|
|
(l1 `(lambda (a b c d)
|
|
(declare (type fixnum b))
|
|
,form))
|
|
(l2 `(lambda (a b c d)
|
|
(declare (optimize (speed 3)))
|
|
,form))
|
|
(f1 (checked-compile l1))
|
|
(f2 (checked-compile l2)))
|
|
(assert (eq (apply f1 vals) :good))
|
|
(assert (eq (apply f2 vals) :good))))
|
|
|
|
(defun count-assembly-labels (lines)
|
|
(count-if (lambda (line &aux (colon (search ": " line)))
|
|
(and colon
|
|
(char= (char line (+ colon 2)) #\L)))
|
|
lines))
|
|
|
|
(with-test (:name :disassembler-label-jump-table-targets)
|
|
(let* ((f (checked-compile
|
|
'(lambda (x)
|
|
(declare (optimize (sb-c:verify-arg-count 0)))
|
|
(case (truly-the fixnum x)
|
|
(0 (a)) (1 (b)) (2 (c)) (3 (d))))
|
|
:allow-style-warnings t))
|
|
(lines (split-string
|
|
(with-output-to-string (s) (disassemble f :stream s))
|
|
#\newline)))
|
|
(assert (>= (count-assembly-labels lines) 4))))
|
|
|
|
(with-test (:name :ecase-symbol->integer-branch-free)
|
|
(let* ((f (checked-compile
|
|
'(lambda (x)
|
|
;; The safety 0 decl skips the arg count check
|
|
;; and trusts that X satisfies symbolp.
|
|
(declare (symbol x) (optimize (safety 0)))
|
|
(ecase x
|
|
((nil) 0) (a 1) (b 2) (c 3) (d 4)
|
|
(e 5) (f 6) (g 7) (h 8) (i 9)))))
|
|
(lines (split-string
|
|
(with-output-to-string (s) (disassemble f :stream s))
|
|
#\newline)))
|
|
;; There is not a conditional branch per symbol
|
|
(assert (= (count-assembly-labels lines) 1))))
|
|
|
|
;;; Assert that the ECASE-FAILURE vop emits a trap and that we don't call ERROR
|
|
;;; (cutting down on the code size for each ECASE)
|
|
(with-test (:name :ecase-failure-trap)
|
|
;; test ECASE
|
|
(assert (ctu:asm-search "ECASE-FAILURE-ERROR"
|
|
`(lambda (x)
|
|
(ecase x (:a 1) (:b 2) (:c 3)))))
|
|
;; test ETYPECASE
|
|
(assert (ctu:asm-search "ETYPECASE-FAILURE-ERROR"
|
|
`(lambda (x)
|
|
(etypecase x
|
|
((integer 1 20) 'hi)
|
|
((cons (eql :thing)) 'wat)
|
|
(bit-vector 'hi-again))))))
|
|
|
|
(with-test (:name :symbol-case-optimization-levels)
|
|
(let ((cases
|
|
'((a 1) (b 1) (c 3/2)
|
|
(d 2) (e 2) (f "hello")
|
|
(g 3) (h 3) (i -3))))
|
|
(dolist (constraint '(t symbol (not null) (and symbol (not null))))
|
|
(dotimes (safety 4)
|
|
(let ((f (checked-compile
|
|
`(lambda (x)
|
|
(declare (optimize (safety ,safety)))
|
|
(case (the ,constraint x) ,@cases (t :feep))))))
|
|
(dolist (input '(a b c d e f g h i j k nil 5 7))
|
|
(when (typep input constraint)
|
|
(assert (eq (funcall f input)
|
|
(let ((cell (assoc input cases)))
|
|
(if cell (cadr cell) :feep)))))))))))
|
|
|
|
(defun count-assembly-lines (f)
|
|
(length (split-string (with-output-to-string (string)
|
|
(disassemble f :stream string))
|
|
#\newline)))
|
|
|
|
(with-test (:name :peephole-optimizations-1 :skipped-on :sbcl)
|
|
;; The test does not check that both the load and the shift
|
|
;; have been sized as :dword instead of :qword, but it should
|
|
;; FIXME: this test was supposed to assert that
|
|
;; "AND r, -2 ; AND r, n" combines the two ANDs into one,
|
|
;; but there is no longer an AND in the symbol-hash vop
|
|
;; so I need to find a different test case.
|
|
(let ((f '(lambda (x)
|
|
;; eliminate arg count check, type check
|
|
(declare (optimize speed (safety 0)))
|
|
(ldb (byte 3 0) (sb-kernel:symbol-hash x)))))
|
|
(let ((unoptimized (let ((sb-c::*do-instcombine-pass* nil))
|
|
(checked-compile f)))
|
|
(instcombined (checked-compile f)))
|
|
(assert (= (count-assembly-lines instcombined)
|
|
(- (count-assembly-lines unoptimized) 1)))))
|
|
|
|
;; Likewise this was "AND RDX, -2 ; SAR RDX, 2 ; AND RDX, -2 ; AND RDX, 62"
|
|
;; becoming "SHR EDX, 2 ; AND EDX, 62"
|
|
(let ((f '(lambda (x)
|
|
;; eliminate arg count check, type check
|
|
(declare (optimize speed (safety 0)))
|
|
(ldb (byte 5 2) (sb-kernel:symbol-hash x)))))
|
|
(let ((unoptimized (let ((sb-c::*do-instcombine-pass* nil))
|
|
(checked-compile f)))
|
|
(instcombined (checked-compile f)))
|
|
(assert (= (count-assembly-lines instcombined)
|
|
(- (count-assembly-lines unoptimized) 2))))))
|
|
|
|
(defun assert-thereis-line (lambda expect)
|
|
(let ((f (checked-compile lambda)))
|
|
(assert
|
|
(loop for line in (split-string (with-output-to-string (string)
|
|
(disassemble f :stream string))
|
|
#\newline)
|
|
;; very brittle, as it looks for a specific register
|
|
thereis (search expect line)))))
|
|
|
|
(with-test (:name :char-code-is-single-shr)
|
|
(assert-thereis-line '(lambda (x) (char-code (truly-the character x)))
|
|
"SHR EDI, 7"))
|
|
|
|
(import '(sb-x86-64-asm::get-gpr sb-x86-64-asm::machine-ea))
|
|
;; to make this pass on different configurations we'd have to add
|
|
;; some abstraction on the PC offsets on each line.
|
|
#+nil
|
|
(with-test (:name :simple-fun-instruction-model)
|
|
(let ((rax (get-gpr :qword sb-vm::rax-offset))
|
|
(eax (get-gpr :dword sb-vm::rax-offset))
|
|
(al (get-gpr :byte sb-vm::rax-offset))
|
|
(rcx (get-gpr :qword sb-vm::rcx-offset))
|
|
(rdx (get-gpr :qword sb-vm::rdx-offset))
|
|
(rsp (get-gpr :qword sb-vm::rsp-offset))
|
|
(rbp (get-gpr :qword sb-vm::rbp-offset)))
|
|
(flet ((compare (a b)
|
|
(and (eql (car a) (car b)) ; PC offs
|
|
(string= (cadr a) (cadr b)) ; inst name
|
|
(equalp (cddr a) (cddr b)))))
|
|
(mapc (lambda (a b)
|
|
(unless (compare a b)
|
|
(error "Didn't match: ~S ~S" a b)))
|
|
(get-simple-fun-instruction-model #'car)
|
|
`(( 0 pop (#s(machine-ea :base 5 :disp 8) . :qword))
|
|
( 3 cmp ,rcx 2)
|
|
( 7 jmp :ne 29)
|
|
( 9 mov ,rsp ,rbp)
|
|
(12 lea ,eax (#s(machine-ea :base 2 :disp -7) . :dword))
|
|
(15 test ,al 15)
|
|
(17 jmp :ne +5) ; = PC offs 24
|
|
(19 mov ,rax ,rdx)
|
|
(22 jmp +4) ; = PC offs 28
|
|
(24 break 71)
|
|
(28 mov ,rdx (#s(machine-ea :base 0 :disp -7) . :qword))
|
|
(32 mov ,rsp ,rbp)
|
|
(35 clc)
|
|
(36 pop ,rbp)
|
|
(37 ret)
|
|
(38 break 16))))))
|
|
|
|
(with-test (:name :typep-compiled-with-jump-table)
|
|
;; Expect to reference the CTYPE layout because %%TYPEP declares its argument
|
|
;; to be that. Expect to reference the UNKNOWN-TYPE layout because of an
|
|
;; explicit call to UNKNOWN-TYPE-P; same for FUN-DESIGNATOR-TYPE-P.
|
|
|
|
;; The other types are referenced from other functions in the code
|
|
;; component.
|
|
(let ((names
|
|
(mapcar (lambda (x)
|
|
(sb-kernel:classoid-name (sb-kernel:layout-classoid x)))
|
|
(ctu:find-code-constants #'sb-kernel:%%typep :type 'sb-kernel:layout))))
|
|
(assert (null (set-difference names
|
|
'(sb-kernel:ctype
|
|
sb-kernel:unknown-type
|
|
sb-kernel:fun-designator-type
|
|
sb-c::abstract-lexenv
|
|
sb-kernel::classoid-cell
|
|
sb-kernel:layout
|
|
sb-kernel:classoid
|
|
sb-kernel:built-in-classoid
|
|
#-immobile-space null))))))
|
|
|
|
;; lp#1857861
|
|
(with-test (:name :undecoded-immediate-data)
|
|
(let ((f (compile nil '(lambda (x) (when (floatp x) 0.0))))
|
|
(expect (format nil ", ~D" sb-vm:single-float-widetag)))
|
|
(loop for line in (split-string (with-output-to-string (string)
|
|
(disassemble f :stream string))
|
|
#\newline)
|
|
thereis (let ((p (search expect line)))
|
|
;; expect no end-of-line comment
|
|
(and p (not (find #\; line :start p))))))
|
|
(let ((f (compile nil '(lambda (x) (sb-ext:process-p x)))))
|
|
(loop for line in (split-string (with-output-to-string (string)
|
|
(disassemble f :stream string))
|
|
#\newline)
|
|
thereis (and (search "LAYOUT for" line)
|
|
(search "CMP DWORD PTR" line)))))
|
|
|
|
(with-test (:name :thread-local-unbound)
|
|
(declare (optimize safety))
|
|
(let ((c (nth-value 1 (ignore-errors sb-c::*compilation*))))
|
|
(assert (eq (cell-error-name c) 'sb-c::*compilation*))))
|
|
|
|
(defstruct foo (s 0 :type (or null string)))
|
|
(with-test (:name :reduce-stringp-to-not-null)
|
|
(let ((f1 (disassembly-lines
|
|
'(lambda (x) (if (null (foo-s (truly-the foo x))) 'not 'is))))
|
|
(f2 (disassembly-lines
|
|
'(lambda (x) (if (stringp (foo-s (truly-the foo x))) 'is 'not)))))
|
|
;; Comparison of X to NIL should be a single-byte test.
|
|
;; Note that the disassembler always treats imm8 operands as signed
|
|
(let ((expect "R12"))
|
|
(assert (loop for line in f1
|
|
thereis (and (search (format nil "CMP ") line) ; register is arbitrary
|
|
(search (format nil ", ~D" expect) line)))))
|
|
;; the two variations of the test compile to the identical code
|
|
(dotimes (i 4)
|
|
(assert (string= (nth i f1) (nth i f2))))))
|
|
|
|
(with-test (:name :make-list-ridiculously-huge)
|
|
(checked-compile '(lambda () (make-list 3826305079707827596))
|
|
:allow-warnings t))
|
|
|
|
(with-test (:name :with-foo-macro-elides-arg-count-trap)
|
|
(let ((lines
|
|
(split-string
|
|
(with-output-to-string (s)
|
|
(sb-c:dis '(lambda (x) (with-standard-io-syntax (eval x))) s))
|
|
#\newline)))
|
|
;; The outer lambda checks its arg count, but the lambda
|
|
;; passed to call-with-mutex does not.
|
|
(assert (= (count-if (lambda (line)
|
|
(search "Invalid argument count trap" line))
|
|
lines)
|
|
1))))
|
|
|
|
(with-test (:name :known-array-rank)
|
|
(flet ((try (type)
|
|
(let ((lines
|
|
(disassembly-lines
|
|
`(lambda (x)
|
|
#+sb-safepoint (declare (optimize (sb-c::insert-safepoints 0)))
|
|
(array-rank (truly-the ,type x))))))
|
|
;; (format t "~{~&~A~}" lines)
|
|
;; Naturally this is brittle as heck. I wish we had a better way.
|
|
(assert (<= (length lines) 9)))))
|
|
(try 'string)
|
|
(try '(and vector (not simple-array)))
|
|
(try '(or string bit-vector)) ; not an array type, but known rank
|
|
(try '(array * (4 5 *)))))
|
|
|
|
;;; Match the same set of objects that %OTHER-POINTER-P does.
|
|
(deftype other-pointer-object ()
|
|
'(not (or fixnum single-float function list sb-kernel:instance character)))
|
|
|
|
;;; Helper to assert something about how many comparisons it takes to test
|
|
;;; for various sets of widetags.
|
|
(defun count-cmp-opcodes (type expect function)
|
|
(let ((lines (disassembly-lines function)))
|
|
(let ((actual
|
|
(loop for line in lines
|
|
count (or (search "CMP" line)
|
|
(search "TEST" line)))))
|
|
(unless (eql actual expect)
|
|
(format t "~{~&~a~}~%" lines)
|
|
(error "typep: needed ~d test ops but expected ~d for ~a"
|
|
actual expect type)))))
|
|
|
|
(defun check-arrayp-cmp-opcodes (expect type)
|
|
;; Assume the lowtag test passed already.
|
|
(count-cmp-opcodes type expect
|
|
`(lambda (x)
|
|
(declare (optimize (sb-c::verify-arg-count 0)
|
|
#+sb-safepoint (sb-c::insert-safepoints 0)))
|
|
(typep (truly-the other-pointer-object x) ',type))))
|
|
|
|
(with-test (:name :arrayp-exactly-one-comparison-etc)
|
|
(check-arrayp-cmp-opcodes 1 'array)
|
|
|
|
(check-arrayp-cmp-opcodes 1 'string)
|
|
(check-arrayp-cmp-opcodes 1 'base-string) ; widetags differing in one bit
|
|
#+sb-unicode
|
|
(check-arrayp-cmp-opcodes 1 'sb-kernel::character-string) ; ditto
|
|
(check-arrayp-cmp-opcodes 1 'simple-string) ; 2 adjacent widetags
|
|
(check-arrayp-cmp-opcodes 1 '(and string (not simple-array)))
|
|
(check-arrayp-cmp-opcodes 1 'simple-base-string)
|
|
#+sb-unicode
|
|
(check-arrayp-cmp-opcodes 1 'sb-kernel::simple-character-string)
|
|
(check-arrayp-cmp-opcodes 1 '(and string (not simple-array)))
|
|
(check-arrayp-cmp-opcodes #+sb-unicode 1
|
|
#-sb-unicode 2
|
|
'(and array (not simple-array)))
|
|
|
|
;; some other interesting pairs
|
|
;; This was passing just by random coincidence.
|
|
;; The widetag patterns no longer differ in exactly 1 bit.
|
|
;; Is there any real relevance to this test?
|
|
#+nil
|
|
(check-arrayp-cmp-opcodes 1 '(or (simple-array (unsigned-byte 8) (*))
|
|
(simple-array (unsigned-byte 16) (*))))
|
|
;; FIXME: what's up with SIMPLE-UNBOXED-ARRAY requiring 1 SUB,
|
|
;; 3 CMPs, and a MOVZX. Something doesn't feel right.
|
|
;; In general, a lot of the array types are source-transforming to
|
|
;; (AND (SB-KERNEL:%OTHER-POINTER-P #:OBJECT0)
|
|
;; (EQ (SB-KERNEL:%OTHER-POINTER-WIDETAG #:OBJECT0) something))
|
|
)
|
|
|
|
(defun show-pretty-lines (type lines)
|
|
(format t ";;;; Type: ~s~%" type)
|
|
(dolist (line lines)
|
|
(when (plusp (length line))
|
|
(let* ((label
|
|
(if (char= (char line 0) #\L)
|
|
(subseq line 0 (1+ (position #\: line)))
|
|
""))
|
|
(opcode-bytes
|
|
(progn
|
|
(setq line (string-left-trim " " (subseq line (length label))))
|
|
(subseq line 0 (position #\Space line)))))
|
|
(setq line (string-left-trim " " (subseq line (length opcode-bytes))))
|
|
(format t "; ~4a~20a~a~%"
|
|
label opcode-bytes line))))
|
|
(terpri))
|
|
|
|
(defun typep-asm-code-length (type &optional print)
|
|
(let* ((lines
|
|
(disassembly-lines
|
|
(compile nil
|
|
`(lambda (x)
|
|
(declare (optimize (sb-c::verify-arg-count 0) (debug 0)))
|
|
(typep x ',type)))))
|
|
(callp
|
|
(some (lambda (x) (or (search "#<FUNCTION" x)
|
|
(search "#<FDEFN" x)))
|
|
lines)))
|
|
(when print (show-pretty-lines type lines))
|
|
(values (length lines) callp)))
|
|
|
|
;;; Counting instructions of assembly is sort of a very rough guess
|
|
;;; as to whether widetags are being tested as efficiently as possible.
|
|
;;; This file is for both human and machine consumption.
|
|
;;; #\! precedes any line where the type test involves a function call.
|
|
;;; It might be just a call. We might consider inlining some of those.
|
|
(defun write-golden-typep-data (input-name output-name)
|
|
(with-open-file (input input-name)
|
|
(with-open-file (output output-name :direction :output
|
|
:if-exists :supersede
|
|
:if-does-not-exist :create)
|
|
(let ((*package* (find-package "SB-KERNEL"))
|
|
(*print-pretty* nil))
|
|
(loop (let ((type (read input nil input)))
|
|
(when (eq type input) (return))
|
|
(multiple-value-bind (linecount callp) (typep-asm-code-length type)
|
|
(format output "~a ~3d ~s~%"
|
|
(if callp "!" " ")
|
|
linecount type))))))))
|
|
|
|
#+nil
|
|
(write-golden-typep-data "../interesting-types.lisp-expr"
|
|
"typep-golden-data.txt")
|
|
|
|
;;; FIXME: Some time after the MANY-INTERESTING-ARRAY-TYPES test
|
|
;;; got disabled, the code size changed either due to a regression,
|
|
;;; or more aggressive inlining of ">=" and "<="
|
|
;;; which now causes these warnings. Figure out the new baseline.
|
|
;;
|
|
;; WARNING: (AND INTEGER (NOT (SIGNED-BYTE 31))) was 32 is 38
|
|
;; WARNING: (AND INTEGER (NOT (SIGNED-BYTE 32))) was 32 is 38
|
|
;; WARNING: (INTEGER (0) *) was 18 is 22
|
|
;; WARNING: (INTEGER * -1) was 18 is 22
|
|
;; WARNING: (INTEGER * -1000000) was 18 is 22
|
|
;; WARNING: (INTEGER * -1073741825) was 18 is 23
|
|
;; WARNING: (INTEGER * -12) was 18 is 22
|
|
;; WARNING: (INTEGER * -14) was 18 is 22
|
|
;; WARNING: (INTEGER * -17) was 18 is 22
|
|
;; WARNING: (INTEGER * -2) was 18 is 22
|
|
;; WARNING: (INTEGER * -2147483649) was 18 is 23
|
|
;; WARNING: (INTEGER * -4611686018427387901) was 18 is 23
|
|
;; WARNING: (INTEGER * -54043195528445951) was 18 is 23
|
|
;; WARNING: (INTEGER * -541073411) was 18 is 22
|
|
;; WARNING: (INTEGER * -6) was 18 is 22
|
|
;; WARNING: (INTEGER * -9) was 18 is 22
|
|
;; WARNING: (INTEGER * 0) was 24 is 22
|
|
;; WARNING: (INTEGER * 20) was 18 is 22
|
|
;; WARNING: (INTEGER * 2047) was 18 is 22
|
|
;; WARNING: (INTEGER * 2147483647) was 18 is 23
|
|
;; WARNING: (INTEGER * 4611686018427387900) was 18 is 23
|
|
;; WARNING: (INTEGER * 576460752303423487) was 18 is 23
|
|
;; WARNING: (INTEGER * 65535) was 18 is 22
|
|
;; WARNING: (INTEGER -1) was 18 is 22
|
|
;; WARNING: (INTEGER 1) was 18 is 22
|
|
;; WARNING: (INTEGER 1073741824) was 18 is 23
|
|
;; WARNING: (INTEGER 1152921504606846961) was 18 is 23
|
|
;; WARNING: (INTEGER 1899) was 18 is 22
|
|
;; WARNING: (INTEGER 2) was 18 is 22
|
|
;; WARNING: (INTEGER 2147483648) was 18 is 23
|
|
;; WARNING: (INTEGER 2305843009214) was 18 is 23
|
|
;; WARNING: (INTEGER 4611686018427387900) was 18 is 23
|
|
;; WARNING: (INTEGER 4611686018427387901) was 18 is 23
|
|
;; WARNING: (INTEGER 4611686018427387902) was 18 is 23
|
|
;; WARNING: (INTEGER 4611686018427387903) was 18 is 23
|
|
;; WARNING: (INTEGER 63) was 18 is 22
|
|
(defun compare-to-golden-typep-data (pathname &optional print)
|
|
(with-open-file (input pathname)
|
|
(let ((*package* (find-package "SB-KERNEL")))
|
|
(loop (let ((line (read-line input nil input)))
|
|
(when (eq line input) (return))
|
|
(with-input-from-string (stream line :start 2)
|
|
(let ((expect-n (read stream))
|
|
(type (read stream)))
|
|
(multiple-value-bind (linecount callp)
|
|
(typep-asm-code-length type print)
|
|
(declare (ignore callp))
|
|
(when (/= linecount expect-n)
|
|
(warn "~S was ~d is ~d" type expect-n linecount))))))))))
|
|
|
|
#+nil ; gotta figure out how to make this insensitive to standard asm boilerplate
|
|
(with-test (:name :many-interesting-array-types
|
|
:skipped-on (:or (:not :sb-unicode)
|
|
(:not :immobile-space)))
|
|
(compare-to-golden-typep-data "typep-golden-data.txt"))
|
|
|
|
(with-test (:name :integerp->bignump-strength-reduction)
|
|
(let ((f1 (compile nil '(lambda (x)
|
|
(typecase x (fixnum 'a) (integer 'b) (t 'c)))))
|
|
(f2 (compile nil '(lambda (x)
|
|
(typecase x (fixnum 'a) (bignum 'b) (t 'c))))))
|
|
(assert (= (length (disassembly-lines f1))
|
|
(length (disassembly-lines f2))))))
|
|
|
|
(with-test (:name :boundp+symbol-value
|
|
:skipped-on (not :sb-thread))
|
|
;; The vop combiner produces exactly one reference to SB-C::*COMPILATION*.
|
|
;; Previously there would have been one from BOUNDP and one from SYMBOL-VALUE.
|
|
(let ((lines (disassembly-lines
|
|
'(lambda ()
|
|
(declare (optimize safety))
|
|
(if (boundp 'sb-c::*compilation*) sb-c::*compilation*) '(hi)))))
|
|
(dolist (line lines)
|
|
(assert (not (search "ERROR" line))))
|
|
(assert (= (loop for line in lines
|
|
count (search "*COMPILATION*" line))
|
|
1)))
|
|
;; Non-constant symbol works too now
|
|
(let ((lines (disassembly-lines
|
|
'(lambda (x) (if (boundp (truly-the symbol x)) x '(hi))))))
|
|
(dolist (line lines)
|
|
(assert (not (search "ERROR" line))))))
|
|
|
|
;;; We were missing the fndb info that fill-pointer-error doesn't return
|
|
;;; (not exactly "missing", but in the wrong package)
|
|
(with-test (:name :fill-pointer-no-return-multiple)
|
|
(let ((lines (disassembly-lines '(lambda (x) (fill-pointer x)))))
|
|
(dolist (line lines)
|
|
(assert (not (search "RETURN-MULTIPLE" line))))))
|
|
|
|
(with-test (:name :elide-zero-fill)
|
|
(let* ((f (compile nil '(lambda () (make-array 100 :initial-element 0))))
|
|
(lines (disassembly-lines f)))
|
|
(dolist (line lines)
|
|
(assert (not (search "REPE STOSQ" line))))))
|
|
|
|
;;; Word-sized stores (or larger, like double-float on 32-bit) would cons a new lisp object
|
|
(with-test (:name :sap-set-does-not-cons)
|
|
(loop for (type accessor telltale) in
|
|
'((sb-vm:word sb-sys:sap-ref-word "ALLOC-UNSIGNED-BIGNUM")
|
|
(double-float sb-sys:sap-ref-double "ALLOC-TRAMP"))
|
|
do (let* ((positive-test
|
|
(compile nil `(lambda (sap) (,accessor sap 0))))
|
|
(negative-test
|
|
(compile nil `(lambda (sap obj) (setf (,accessor sap 0) obj)))))
|
|
;; Positive test ensures we know the right telltale for the type
|
|
;; in case the allocation logic changes
|
|
(assert (loop for line in (disassembly-lines positive-test)
|
|
thereis (search telltale line)))
|
|
(assert (not (loop for line in (disassembly-lines negative-test)
|
|
thereis (search telltale line)))))))
|
|
|
|
(with-test (:name :bash-copiers-byte-or-larger :skipped-on :sb-devel)
|
|
(dolist (f '(sb-kernel::ub8-bash-copy
|
|
sb-kernel::ub16-bash-copy
|
|
sb-kernel::ub32-bash-copy
|
|
sb-kernel::ub64-bash-copy))
|
|
;; Should not call anything
|
|
(assert (not (ctu:find-code-constants (symbol-function f))))))
|
|
|
|
(defstruct bitsy
|
|
(fix 0 :type fixnum)
|
|
(sw 0 :type sb-vm:signed-word))
|
|
|
|
(defun s62 (x) (logtest (ash 1 62) (bitsy-fix x)))
|
|
(compile 's62)
|
|
(with-test (:name :lp-1939897)
|
|
(assert (not (s62 (make-bitsy :fix (ash 1 61))))))
|
|
|
|
(defmacro try-logbitp-walking-bit-test
|
|
(slot-name initarg nbits most-negative-value)
|
|
`(let ((functions (make-array ,nbits)))
|
|
(flet ((bit-num-to-value (b)
|
|
(if (= b ,(1- nbits)) ,most-negative-value (ash 1 b))))
|
|
(loop for bit-index from 0 below ,nbits
|
|
do (setf (aref functions bit-index)
|
|
(compile nil `(lambda (obj)
|
|
(values (logtest ,(bit-num-to-value bit-index)
|
|
(,',slot-name obj))
|
|
(logbitp ,bit-index (,',slot-name obj)))))))
|
|
(loop for set-bit-index from 0 below ,nbits
|
|
do (let ((struct (make-bitsy ,initarg
|
|
(bit-num-to-value set-bit-index))))
|
|
(loop for test-bit-index from 0 below ,nbits
|
|
do (multiple-value-bind (value1 value2)
|
|
(funcall (aref functions test-bit-index) struct)
|
|
;; The expressions should agree at each bit
|
|
(assert (eq value1 value2))
|
|
;; And should give the right answer
|
|
(if (= test-bit-index set-bit-index)
|
|
(assert value1)
|
|
(assert (not value1))))))))))
|
|
|
|
(with-test (:name :logbitp-vs-logtest-exhaustive-test)
|
|
(try-logbitp-walking-bit-test bitsy-fix :fix 63
|
|
most-negative-fixnum)
|
|
(try-logbitp-walking-bit-test bitsy-sw :sw 64
|
|
(sb-c::mask-signed-field 64 (ash 1 63))))
|
|
|
|
#+allocator-metrics ; missing symbols if absent feature
|
|
(with-test (:name :allocator-histogram-bucketing)
|
|
(let* ((min 0) (max 5000)
|
|
(var-fun (compile nil '(lambda (n) (make-array (the fixnum n))))))
|
|
(loop for n-elements from min to max
|
|
do
|
|
(let* ((fixed-fun (compile nil `(lambda () (make-array ,n-elements))))
|
|
(h1 (progn
|
|
(sb-thread::reset-allocator-histogram)
|
|
(funcall fixed-fun)
|
|
(first (sb-thread::allocator-histogram))))
|
|
(h2 (progn
|
|
(sb-thread::reset-allocator-histogram)
|
|
(funcall var-fun n-elements)
|
|
(first (sb-thread::allocator-histogram)))))
|
|
;; We have to allow for the possibilty of either or both MAKE-ARRAY calls causing
|
|
;; a GC to occur immediately thereafter, which allocates a cons for the GC epoch.
|
|
;; So if there is an extra element in bin 0, just remove it.
|
|
(when (and (> (aref h1 0) 0)
|
|
(= (loop for value across h1 sum value) 2))
|
|
(decf (aref h1 0)))
|
|
(when (and (> (aref h2 0) 0) (= (loop for value across h2 sum value) 2))
|
|
(decf (aref h2 0)))
|
|
(unless (and (= (loop for value across h1 sum value) 1) ; exactly 1 bucket is nonzero
|
|
(equalp h1 h2))
|
|
(let ((*print-length* nil))
|
|
(format t "h1=~s~%h2=~s~%" h1 h2)
|
|
(error "Error on n-elements = ~d" n-elements)))))))
|
|
|
|
(with-test (:name :uniquify-fixups)
|
|
(let* ((f (let ((sb-c::*compile-to-memory-space* :dynamic))
|
|
(compile nil
|
|
'(lambda (x)
|
|
`(,(list 1 2) ,(cons 1 2) ,(list nil x) ,(list '(a) #\x))))))
|
|
(fixups
|
|
(sb-c:unpack-code-fixup-locs
|
|
(sb-vm::%code-fixups (sb-kernel:fun-code-header f)))))
|
|
;; There are 5 call outs to the fallback allocator, but only 2 (or 3)
|
|
;; fixups to the asm routines, because of uniquification per code component.
|
|
;; 2 of them are are CONS->RNN and CONS->R11
|
|
;; the other is ENABLE-ALLOC-COUNTER which may or may not be present
|
|
(assert (<= (length fixups) 3))))
|
|
|
|
(defstruct submarine x y z)
|
|
(defstruct (moreslots (:include submarine)) a b c)
|
|
(declaim (ftype (function () double-float) get-dbl))
|
|
(with-test (:name :write-combining-instance-set)
|
|
(let* ((f (compile nil '(lambda (s)
|
|
(setf (submarine-x (truly-the submarine s)) 0
|
|
(submarine-y s) 0
|
|
(submarine-z s) 0))))
|
|
(lines (disassembly-lines f)))
|
|
(assert (= 1 (loop for line in lines count (search "MOVUPD" line))))
|
|
(assert (= 1 (loop for line in lines count (search "MOVSD" line)))))
|
|
(let* ((f (compile nil '(lambda (s)
|
|
(setf (moreslots-a (truly-the moreslots s)) 0
|
|
(submarine-x s) 0
|
|
(moreslots-c s) 0))))
|
|
(lines (disassembly-lines f)))
|
|
(assert (= 3 (loop for line in lines count (search "MOVSD" line)))))
|
|
;; This was crashing in the MOV emitter (luckily) because it received
|
|
;; an XMM register due to omission of a MOVE-FROM-DOUBLE to heap-allocate.
|
|
(compile nil
|
|
'(lambda (sub a)
|
|
(declare (submarine sub))
|
|
(let ((fooval (+ (get-dbl) 23d0)))
|
|
(setf (submarine-x sub) a
|
|
(submarine-y sub) fooval)
|
|
a))))
|
|
|
|
(sb-vm::define-vop (trythis)
|
|
(:generator 1
|
|
(sb-vm::inst and sb-vm::rax-tn (sb-c:make-fixup nil :card-table-index-mask))))
|
|
(defun zook ()
|
|
(sb-sys:%primitive trythis)
|
|
nil)
|
|
|
|
;;; Previously INITIALIZE-VECTOR would move every element into
|
|
;;; a register, causing each to require a store barrier
|
|
;;; and then a register-to-memory move like so:
|
|
;;; BB02000000 MOV EBX, 2
|
|
;;; 488D4601 LEA RAX, [RSI+1]
|
|
;;; 48C1E80A SHR RAX, 10
|
|
;;; 25FFFF0F00 AND EAX, 1048575
|
|
;;; 41C6040400 MOV BYTE PTR [R12+RAX], 0
|
|
;;; 48895E01 MOV [RSI+1], RBX
|
|
;;; The improved code emits 4 consecutive MOV instructions,
|
|
;;; one per item. It is still suboptimal in that it can not discern
|
|
;;; between initializing and updating, so it always uses a :QWORD move
|
|
;;; despite the prezeroed pages.
|
|
(with-test (:name :init-vector-mov-to-mem
|
|
:skipped-on :debug-gc-barriers)
|
|
(let* ((lines (disassembly-lines
|
|
'(lambda () (vector #\x 1 2 3))))
|
|
(magic-value
|
|
(write-to-string
|
|
(logior (ash (char-code #\x) 8) sb-vm:character-widetag)))
|
|
(start
|
|
(position-if
|
|
(lambda (line) (search magic-value line))
|
|
lines)))
|
|
(assert start)
|
|
(assert (search ", 2" (nth (+ start 1) lines)))
|
|
(assert (search ", 4" (nth (+ start 2) lines)))
|
|
(assert (search ", 6" (nth (+ start 3) lines)))))
|
|
|
|
(defglobal *myglobalvar* 3)
|
|
(with-test (:name :disassemble-symbol-global-value)
|
|
(assert (loop for line in (disassembly-lines '(lambda () *myglobalvar*))
|
|
thereis (search "*MYGLOBALVAR*" line))))
|
|
|
|
(defun compiler-trace-output-lines (lexpr)
|
|
(let ((string-stream (make-string-output-stream)))
|
|
(let ((sb-c::*compiler-trace-output* string-stream)
|
|
(sb-c::*compile-trace-targets* '(:vop))
|
|
(*print-pretty* nil))
|
|
(compile nil lexpr))
|
|
(split-string (get-output-stream-string string-stream)
|
|
#\newline)))
|
|
|
|
;;; Return the list of vops (as strings) that emitted a GC barrier.
|
|
(defun find-gc-barriers (lambda-expression)
|
|
(let ((lines
|
|
(compiler-trace-output-lines lambda-expression))
|
|
(current-vop)
|
|
(result))
|
|
;; FIXME: can this miss vops on a label line, or do we always print labels
|
|
;; on their own line?
|
|
(dolist (line lines (nreverse result))
|
|
(let ((line (pop lines)))
|
|
(cond ((and (>= (length line) 4) (string= line "VOP " :end1 4))
|
|
(let ((string (subseq line 4 (position #\space line :start 5))))
|
|
(setq current-vop string)))
|
|
((search ":FLAVOR CARD-TABLE-INDEX-MASK" line)
|
|
(push current-vop result)))))))
|
|
|
|
(with-test (:name :closure-init-gc-barrier)
|
|
(let ((vops-with-barrier
|
|
(find-gc-barriers
|
|
'(lambda (address)
|
|
(let ((sap (sb-sys:int-sap (truly-the sb-vm:word address))))
|
|
;; The compiler conses the SAP *after* making the closure, so the store
|
|
;; of the sap into the closure needs a barrier, as it's an old->young store.
|
|
(lambda () sap))))))
|
|
(assert (equal vops-with-barrier '("CLOSURE-INIT")))))
|
|
|
|
(defstruct (point (:constructor make-point (x))) x (y 0) (z 0))
|
|
(with-test (:name :structure-init-gc-barrier)
|
|
(let ((vops-with-barrier
|
|
(find-gc-barriers
|
|
'(lambda (val)
|
|
(declare (double-float val) (inline make-point))
|
|
;; Similarly to the closure-init test, DOUBLE-FLOAT reg is cast to
|
|
;; DESCRIPTOR-REG only after making the object. This seems like a
|
|
;; low-hanging-fruit optimization to flip the order.
|
|
(let ((neg (- val))) (make-point neg))))))
|
|
(assert (equal vops-with-barrier '("SET-SLOT")))))
|
|
|
|
(with-test (:name :system-tlabs :skipped-on (not :system-tlabs))
|
|
(assert (loop for line in (disassembly-lines 'sb-impl:test-make-packed-info)
|
|
thereis (search "SYS-ALLOC-TRAMP" line)))
|
|
(assert (loop for line in (disassembly-lines 'sb-impl:test-copy-packed-info)
|
|
thereis (search "SYS-ALLOC-TRAMP" line)))
|
|
(let ((f (compile nil '(lambda (x)
|
|
(declare (sb-c::tlab :system))
|
|
(sb-pcl::%copy-cache x)))))
|
|
(assert (loop for line in (disassembly-lines f)
|
|
thereis (search "SYS-ALLOC-TRAMP" line)))))
|
|
|
|
(defun find-in-disassembly (string lambda-expression)
|
|
(let ((disassembly
|
|
(with-output-to-string (s)
|
|
(disassemble (compile nil lambda-expression) :stream s))))
|
|
(loop for line in (split-string disassembly #\Newline)
|
|
thereis (search string line))))
|
|
|
|
#+immobile-space
|
|
(with-test (:name :disassemble-alien-linkage-table-ref
|
|
:fails-on (or (not :sb-thread) :win32))
|
|
(dolist (memspace '(:dynamic :immobile))
|
|
(let ((sb-c::*compile-to-memory-space* memspace))
|
|
(assert (find-in-disassembly
|
|
"lose"
|
|
'(lambda ()
|
|
(declare (optimize (sb-c::alien-funcall-saves-fp-and-pc 0)))
|
|
(alien-funcall (extern-alien "lose" (function void))))))
|
|
(assert (find-in-disassembly
|
|
"&verify_gens"
|
|
'(lambda ()
|
|
(extern-alien "verify_gens" char)))))))
|
|
|
|
;;; This tests that the x86-64 disasembler does not crash
|
|
;;; on LEA with a rip-relative operand and no label.
|
|
(with-test (:name (disassemble :no-labels))
|
|
(let* ((lines
|
|
(split-string
|
|
(with-output-to-string (stream)
|
|
;; A smallish function whose code happens to contain
|
|
;; the thing under test.
|
|
(disassemble 'sb-impl::inspector :stream stream))
|
|
#\Newline))
|
|
(line (find "; = L0" lines :test 'search)))
|
|
(assert (search "LEA " line)) ; verify our test precondition
|
|
;; Now just disassemble without labels and see that we don't crash
|
|
(disassemble 'sb-impl::inspector
|
|
:use-labels nil
|
|
:stream (make-broadcast-stream))))
|
|
|
|
#+immobile-space
|
|
(with-test (:name (disassemble :static-call))
|
|
(dolist (sym '(sb-kernel:two-arg-* sb-kernel:two-arg-/
|
|
sb-kernel:two-arg-+ sb-kernel:two-arg--))
|
|
(let ((f (let ((sb-c:*compile-to-memory-space* :dynamic))
|
|
(compile nil `(lambda (x y) (,sym x y))))))
|
|
(assert (loop for line in (disassembly-lines f)
|
|
thereis (search (princ-to-string sym) line))))))
|
|
|
|
(with-test (:name :closure-gc-barrier)
|
|
(let ((vops-with-barrier
|
|
(find-gc-barriers
|
|
'(lambda ()
|
|
(let ((c (cons 1 2)))
|
|
(lambda (x)
|
|
(setf (car c) x)))))))
|
|
(assert (equal vops-with-barrier '("SET-SLOT")))))
|
|
|
|
(defstruct (wordpair (:predicate nil) (:copier nil)) a b)
|
|
(defun func (x) (wordpair-b x))
|
|
(with-test (:name :non-stack-instance-set)
|
|
;; This is a trivial test of the control case for :stack-instance-set
|
|
(let ((vops-with-barrier
|
|
(find-gc-barriers
|
|
'(lambda (x)
|
|
(declare (inline make-wordpair))
|
|
(let ((pair (make-wordpair :a 'foo)))
|
|
(setf (wordpair-b pair) (car x))
|
|
(values (func pair)))))))
|
|
(assert (equal vops-with-barrier '("INSTANCE-INDEX-SET")))))
|
|
|
|
(with-test (:name :stack-instance-set)
|
|
(let ((vops-with-barrier
|
|
(find-gc-barriers
|
|
'(lambda ()
|
|
(declare (inline make-wordpair))
|
|
(let ((pair (make-wordpair :a 'foo)))
|
|
(declare (dynamic-extent pair))
|
|
(setf (wordpair-b pair) "hi")
|
|
(values (func pair)))))))
|
|
(assert (not vops-with-barrier))))
|
|
|
|
(declaim (freeze-type wordpair))
|
|
(with-test (:name :stack-instance-copy)
|
|
(let ((vops-with-barrier
|
|
(find-gc-barriers
|
|
'(lambda (x)
|
|
(let ((copy (copy-structure (truly-the wordpair x))))
|
|
(declare (dynamic-extent copy))
|
|
(values (func copy)))))))
|
|
(assert (not vops-with-barrier))))
|
|
|
|
;;; word-sized add, subtract, multiply vops which yield either a fixnum
|
|
;;; or bignum where the bignum can have 1, 2, or 3 bigdigits.
|
|
(defparameter unsigned-word-test-inputs
|
|
(loop for i from 0 by (ash 1 56) repeat 256 collect i))
|
|
|
|
(defparameter signed-word-test-inputs
|
|
(funcall
|
|
(compile nil ;; no interpreter stubs
|
|
`(lambda ()
|
|
(loop for word in unsigned-word-test-inputs
|
|
collect (let ((b (sb-bignum:%allocate-bignum 1)))
|
|
(setf (sb-bignum:%bignum-ref b 0) word)
|
|
(sb-bignum::%normalize-bignum b 1)))))))
|
|
|
|
(defun check-result (fun x y actual)
|
|
(let ((expect (funcall fun x y)))
|
|
(unless (eql actual expect)
|
|
(when (typep expect 'bignum)
|
|
(sb-vm:hexdump expect)
|
|
(terpri)
|
|
(sb-vm:hexdump actual))
|
|
(error "Failure @ ~X ~A ~X, expect ~D (~A) got ~D~%"
|
|
x fun y expect
|
|
(typecase expect
|
|
(fixnum 'fixnum)
|
|
(bignum (format nil "~d-word bignum"
|
|
(sb-bignum:%bignum-length expect))))
|
|
actual))))
|
|
|
|
(macrolet ((test-op (op)
|
|
`(progn
|
|
(format t "~&Testing ~A~%" ',op)
|
|
(dolist (x signed-word-test-inputs)
|
|
(dolist (y signed-word-test-inputs)
|
|
(check-result
|
|
',op x y
|
|
(,op (the sb-vm:signed-word x) (the sb-vm:signed-word y))))))))
|
|
(defun test-signed ()
|
|
(test-op +)
|
|
(test-op -)
|
|
(test-op *)))
|
|
|
|
(macrolet ((test-op (op)
|
|
`(progn
|
|
(format t "~&Testing ~A~%" ',op)
|
|
(dolist (x unsigned-word-test-inputs)
|
|
(dolist (y unsigned-word-test-inputs)
|
|
(check-result
|
|
',op x y
|
|
(,op (the sb-vm:word x) (the sb-vm:word y))))))))
|
|
(defun test-unsigned ()
|
|
(test-op +)
|
|
(test-op -)
|
|
(test-op *)))
|
|
|
|
(with-test (:name :signed-vops) (test-signed))
|
|
(with-test (:name :unsigned-vops) (test-unsigned))
|
|
|
|
(with-test (:name :smaller-than-qword-cons-slot-init
|
|
:skipped-on (:not :mark-region-gc))
|
|
(let ((lines (disassembly-lines
|
|
(compile nil '(lambda (a) (list 1 a #\a #xfff000))))))
|
|
(assert (loop for line in lines
|
|
thereis (search "MOV BYTE PTR" line))) ; constant 1
|
|
(assert (loop for line in lines
|
|
thereis (search "MOV WORD PTR" line))) ; constant #\a
|
|
(assert (loop for line in lines
|
|
thereis (search "MOV DWORD PTR" line))))) ; constant #xfff000
|
|
|
|
(defun count-labeled-instructions (function &aux (answer 0))
|
|
(let ((lines (disassembly-lines function)))
|
|
(dolist (line lines answer)
|
|
(when (and (>= (length line) 3)
|
|
(char= (char line 0) #\L)
|
|
(let ((p (position #\: line)))
|
|
(every #'digit-char-p (subseq line 1 p))))
|
|
(incf answer)))))
|
|
|
|
;;; Jump-to-jump elimination helps with conditional vops (those returning the result in EFLAGS)
|
|
;;; which also contain an internal jump, and naturally are followed by a conditional jump.
|
|
;;; It's usually possible to redirect the internal jump, if it has either exactly the same
|
|
;;; sense of or is exactly the negation of the jump that follows the vop.
|
|
(with-test (:name :jump-to-jump-elimination)
|
|
;; NON-NULL SYMBOL-P tests lowtag and widetag, and thus has 2 jumps
|
|
;; but there's only 1 target of a jump.
|
|
(assert (= (count-labeled-instructions
|
|
(checked-compile
|
|
`(lambda (x)
|
|
(declare (optimize (sb-c::verify-arg-count 0)))
|
|
(if (sb-kernel:non-null-symbol-p x) 'zook (eval x)))))
|
|
1)))
|
|
|
|
(with-test (:name :disassemble-instance-type-test
|
|
:skipped-on (not :immobile-space))
|
|
(let ((lines
|
|
(disassembly-lines
|
|
(compile nil '(lambda (m) (the sb-thread:mutex m))))))
|
|
(assert
|
|
(loop for line in lines
|
|
thereis (and (search "CMP DWORD PTR" line)
|
|
(search "#<SB-KERNEL:LAYOUT" line)
|
|
(search "for SB-THREAD:MUTEX" line))))))
|
|
|
|
(with-test (:name :dx-list-push-imm :skipped-on (not :immobile-space))
|
|
(let ((lines
|
|
(disassembly-lines
|
|
(compile nil '(lambda (f)
|
|
(sb-int:dx-let ((x (list :foo))) (funcall f x)))))))
|
|
(assert
|
|
(loop for line in lines
|
|
thereis (and (search "PUSH #x" line) (search "':FOO" line))))))
|
|
|
|
(defun check-hasnot (instructions lexpr)
|
|
(let ((f (compile nil lexpr)))
|
|
(dolist (inst (get-simple-fun-instruction-model f))
|
|
(let ((mnemonic (second inst)))
|
|
(assert (not (find mnemonic instructions :test 'string=)))))))
|
|
|
|
(with-test (:name :compute-lisp-bool-from-c-bool :skipped-on (:not :sb-thread))
|
|
(check-hasnot '("JMP")
|
|
'(lambda (x)
|
|
(declare (optimize (sb-c::verify-arg-count 0)))
|
|
(= (truly-the fixnum x) 1))))
|
|
|
|
(with-test (:name :compute-c-bool-from-lisp-bool)
|
|
(check-hasnot '("JMP" "CMOV")
|
|
'(lambda (x)
|
|
(declare (optimize (sb-c::verify-arg-count 0)))
|
|
(if x 1 0))))
|
|
|
|
(with-test (:name :pcl-ctor-slotv-allocator)
|
|
(flet ((get-asm-lines (n)
|
|
(disassembly-lines
|
|
(compile nil
|
|
`(lambda () (make-array ,n :initial-element sb-pcl:+slot-unbound+))))))
|
|
(let ((lines (get-asm-lines 1)))
|
|
(assert (loop for line in lines
|
|
thereis (and (search "MOV QWORD PTR" line)
|
|
(search "], 9" line))))) ; UNBOUND-MARKER-WIDETAG
|
|
(loop for nelts from 2 to 10
|
|
do (let ((lines (get-asm-lines nelts)))
|
|
(assert (loop for line in lines
|
|
thereis (search "MOVDDUP XMM" line)))))
|
|
(let ((lines (get-asm-lines 11)))
|
|
(assert (loop for line in lines
|
|
thereis (search "REPE STOSQ" line))))))
|
|
|
|
(defconstant arb-qword-const-positive #xFFF0abcdabcd0000)
|
|
(defconstant arb-qword-const-negative (sb-disassem::sign-extend arb-qword-const-positive 64))
|
|
(pushnew :popcnt sb-c:*backend-subfeatures*)
|
|
(defun same-constants-after-collapsing (uw sw)
|
|
(declare (sb-vm:word uw) (sb-vm:signed-word sw))
|
|
(values (logcount (logxor uw arb-qword-const-positive))
|
|
(logcount (logxor sw arb-qword-const-negative))))
|
|
(compile 'same-constants-after-collapsing)
|
|
(defun different-constants (uw sw)
|
|
(declare (sb-vm:word uw) (sb-vm:signed-word sw))
|
|
(values (logcount (logxor uw (logior arb-qword-const-positive 1)))
|
|
(logcount (logxor sw arb-qword-const-negative))))
|
|
(compile 'different-constants)
|
|
|
|
(with-test (:name :constantize-equivalence)
|
|
;; two raw words: jump table count word, and one user constant
|
|
(assert (= 16 (sb-kernel:code-n-unboxed-data-bytes
|
|
(sb-kernel:fun-code-header #'same-constants-after-collapsing))))
|
|
;; four raw words: jump table count word, two user data words, and a padding word
|
|
(assert (= 32 (sb-kernel:code-n-unboxed-data-bytes
|
|
(sb-kernel:fun-code-header #'different-constants)))))
|
|
|
|
(with-test (:name :push-cons)
|
|
(let ((f (checked-compile
|
|
'(lambda (alist x y)
|
|
(declare (optimize (sb-c:instrument-consing 0)))
|
|
(push (cons x y) alist)))))
|
|
;; should have 1 call to list-alloc-tramp, not one for the cons of x, y and one for push
|
|
(assert (= 1 (count 'sb-c:call (get-simple-fun-instruction-model f) :key 'second)))))
|
|
|
|
#+sb-thread
|
|
(with-test (:name :tls-symbol-map)
|
|
(let ((sap (sb-sys:int-sap (ash sb-vm::*tls-symbol-map* sb-vm:n-fixnum-tag-bits)))
|
|
(divisor (or #+tls-load-indirect 16 8)))
|
|
(dotimes (i (ash (ash sb-vm::*free-tls-index* sb-vm:n-fixnum-tag-bits)
|
|
(- sb-vm:word-shift)))
|
|
(unless (= (sb-sys:sap-ref-word sap (ash i sb-vm:word-shift)) sb-vm:no-tls-value-marker)
|
|
(let ((sym (sb-sys:sap-ref-lispobj sap (ash i sb-vm:word-shift))))
|
|
(assert (= (floor (sb-kernel:symbol-tls-index sym) divisor) i)))))))
|
|
|
|
#+sb-thread
|
|
(with-test (:name :tls-index-validity :skipped-on (:not :tls-load-indirect))
|
|
(let ((index-of-package (ash (sb-kernel:symbol-tls-index '*package*)
|
|
(- sb-vm:word-shift))))
|
|
(do-all-symbols (sym)
|
|
(let ((index (ash (sb-kernel:symbol-tls-index sym) (- sb-vm:word-shift))))
|
|
(when (plusp index)
|
|
;; Every TLS slot below *PACKAGE* corresponds to an always-thread-local special.
|
|
(if (< index index-of-package)
|
|
(assert (typep (sb-int:info :variable :wired-tls sym)
|
|
'(or (eql :always-thread-local) integer)))
|
|
(assert (oddp index)))
|
|
;; No always-thread-local special clashes with *PACKAGE*'s indirection cell
|
|
(assert (/= index (1- index-of-package))))))))
|
|
|
|
(defstruct frozenthing)
|
|
(defstruct (specialthing (:include frozenthing)))
|
|
(defstruct (subspecialthing (:include specialthing)))
|
|
(defstruct (otherspecialthing (:include frozenthing)))
|
|
(declaim (freeze-type frozenthing))
|
|
(with-test (:name :typep-layout-eq-one-type)
|
|
(let ((expr `(lambda (x)
|
|
(declare (optimize (sb-c::verify-arg-count 0)))
|
|
(the (and frozenthing (not (or specialthing otherspecialthing))) x)))
|
|
(comparisons 0)
|
|
(saw-layout))
|
|
;; there should be exactly one CMP instruction comparing to #<LAYOUT for THING>
|
|
(dolist (line (disassembly-lines (compile nil expr)))
|
|
(when (search "CMP " line)
|
|
(incf comparisons)
|
|
(when (and (search "#<SB-KERNEL:LAYOUT" line)
|
|
(search "FROZENTHING" line))
|
|
(setq saw-layout t))))
|
|
(assert (and saw-layout (eql comparisons 1)))))
|
|
|
|
(with-test (:name :alien-deref-sign-extend-once-only)
|
|
(let ((lines (disassembly-lines
|
|
'(lambda ()
|
|
(declare (optimize (debug 0)))
|
|
(deref (alien-funcall (extern-alien "f" (function (* char)))) 0)))))
|
|
(assert (eql (loop for line in lines count (search "MOVSX" line)) 1))))
|
|
|
|
(with-test (:name :alien-deref-indexed)
|
|
(let ((lines (disassembly-lines
|
|
'(lambda (i)
|
|
(declare (optimize (debug 0)))
|
|
(let ((a (alien-funcall (extern-alien "f" (function (* unsigned-int))))))
|
|
(deref a (sb-ext:truly-the sb-int:index i)))))))
|
|
;; some line should have a MOV instruction with a base and scaled index,
|
|
;; it should have a #\+ and #\* operation in the effective address.
|
|
;; Since the index is a tagged fixnum, the scale should be 2 which
|
|
;; equates to 4 in bytes.
|
|
(assert
|
|
(some (lambda (line)
|
|
(and (search "MOV" line) (search "+R" line) (search "*2]" line)))
|
|
lines))))
|
|
|
|
(defstruct test-struct-alpha)
|
|
(defstruct test-struct-beta)
|
|
(defstruct test-struct-gamma)
|
|
|
|
(with-test (:name :hoist-typecase-layout-id)
|
|
(let* ((f (compile nil '(lambda (x)
|
|
(declare (optimize speed))
|
|
(typecase x
|
|
(test-struct-alpha 1)
|
|
(test-struct-beta 2)
|
|
(test-struct-gamma 3)))))
|
|
(lines (disassembly-lines f))
|
|
(mem-cmps (loop for line in lines
|
|
count (and (search "CMP" line)
|
|
(search "[" line))))
|
|
(reg-cmps (loop for line in lines
|
|
count (and (search "CMP" line)
|
|
(not (search "[" line))))))
|
|
(assert (eql (funcall f (make-test-struct-alpha)) 1))
|
|
(assert (eql (funcall f (make-test-struct-beta)) 2))
|
|
(assert (eql (funcall f (make-test-struct-gamma)) 3))
|
|
(assert (eql (funcall f "other") nil))
|
|
(assert (>= reg-cmps 3))
|
|
(assert (<= mem-cmps 1))))
|
|
|
|
(with-test (:name :single-struct-typep-fused-cmp)
|
|
(let* ((f (compile nil '(lambda (x)
|
|
(declare (optimize speed))
|
|
(if (typep x 'test-struct-alpha) 1 2))))
|
|
(lines (disassembly-lines f))
|
|
(mem-cmps (loop for line in lines
|
|
count (and (search "CMP" line)
|
|
(search "[" line))))
|
|
(reg-cmps (loop for line in lines
|
|
count (and (search "CMP" line)
|
|
(not (search "[" line))))))
|
|
(assert (eql (funcall f (make-test-struct-alpha)) 1))
|
|
(assert (eql (funcall f "other") 2))
|
|
;; Must keep the single fused memory CMP and avoid separate register CMPs
|
|
(assert (= mem-cmps 1))
|
|
(assert (= reg-cmps 0))))
|
|
|
|
(with-test (:name :specifically-sized-ea-disp)
|
|
(let* ((lines
|
|
(disassembly-lines
|
|
(compile
|
|
nil
|
|
'(lambda ()
|
|
sb-vm::(inline-vop (((x int-sse-reg))) ()
|
|
(inst movdqa (ea 0 rdx-tn) x)
|
|
(inst movdqa (ea :disp8 0 rdx-tn) x)
|
|
(inst movdqa (ea :disp32 0 rdx-tn) x))))))
|
|
(found (member "MOVDQA [RDX], XMM0" lines :test #'search))
|
|
(disp8 (cadr found))
|
|
(disp32 (caddr found)))
|
|
(assert (search "660F7F4200 MOVDQA [RDX], XMM0" disp8))
|
|
(assert (search "660F7F8200000000 MOVDQA [RDX], XMM0" disp32))))
|