common-lisp/sbcl.sbcl
1
0
Fork 0
mirror of git://git.code.sf.net/p/sbcl/sbcl synced 2026-09-10 07:26:40 -04:00
Code Issues Actions 8 Packages Projects Releases Wiki Activity
sbcl.sbcl/tests/compiler-2.pure.lisp
Douglas Katzman 4abf6ef5f7 x86-64: Implement "possible win" cited in calling-convention.texinfo 
Create a dedicated area of 'struct thread' to return multiple-values in excess
of the arg-passing registers. Gating feature is :TLS-BASED-MV-RETURN and not
enabled by default. The limit of 64 (inclusive) values is the minimum to get
most existing tests to pass unchanged.  After the optimizations outlined below
are done, the feature will be more compelling, and we can see about making it
opt-out rather than opt-in, or making MULTIPLE-VALUES-LIMIT configurable.
(I'm sure that some user will claim to need 1000 values.)

The benefit will be fully realized in some subsequent changes, namely:
freeing a DX alloc, unbinding a special var, and breaking up a catch block
will all return from their frame without invoking RETURN-MULTIPLE. Similarly,
some "simple" unwind-protect forms such as release-mutex could too- anything
that does not clobber the thread-local area during a cleanup.
Also this alleviates a big impediment to creating an LLVM-based backend
which could explore performance differences among the call conventions
offered, since micro-management of the stack becomes less critical.

Co-authored with Antigravity
2026-08-30 15:51:25 -04:00

5185 lines
154 KiB
Common Lisp
Raw Blame History

;;;; various compiler tests without side effects
;;;; 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.
;;;; This file of tests was added because the tests in 'compiler.pure.lisp'
;;;; are a total hodgepodge- there is often no hugely compelling reason for
;;;; their being tests of the compiler per se, such as whether
;;;; INPUT-ERROR-IN-COMPILED-FILE is a subclass of SERIOUS-CONDITION;
;;;; in addition to which it is near impossible to wade through the
;;;; ton of nameless, slow, and noisy tests.
;;;; This file strives to do better on all fronts:
;;;; the tests should be fast, named, and not noisy.
(enable-test-parallelism)
(defun compiles-with-warning (lambda)
(assert (nth-value 2 (checked-compile lambda :allow-warnings t))))
(with-test (:name :duplicate-labels)
(dolist (operator '(labels flet macrolet))
(multiple-value-bind (fun warn err)
(let ((*error-output* (make-broadcast-stream)))
(compile nil `(lambda (x)
(declare (ignorable x))
(,operator ((f (z) z 2)
(f (z) z 3))
(f x)))))
;; I'm not asserting on the result of calling FUN
;; because I don't really care what it is.
(declare (ignore fun))
(assert (and warn err)))))
(with-test (:name (position :derive-type))
(checked-compile '(lambda (x)
(ash 1 (position (the (member a b c) x) #(a b c )))))
(checked-compile '(lambda (x)
(ash 1 (position x #(a b c ))))
:allow-style-warnings t)
;; The sequence must contain a mixture of symbols and non-symbols
;; to call %FIND-POSITION. If only symbols, it makes no calls.
(let ((calls (ctu:ir1-funargs '(lambda (x)
(position x '(1 2 3 a b c 4 5 6 d e f g "x") :from-end t)))))
;; Assert that the default :TEST of #'EQL was strength-reduced to #'EQ
(assert (equal calls '((sb-kernel:%find-position identity eq)))))
(checked-compile-and-assert ()
'(lambda (x)
(position x '(a b c d e d c b a) :from-end t))
(('a) 8)
(('b) 7)))
(with-test (:name (ldb :recognize-local-macros))
;; Should not call %LDB
(assert (equal
(ctu:ir1-named-calls
'(lambda (x)
(declare (optimize speed))
(macrolet ((b () '(byte 2 2)))
(ldb (b) (the fixnum x)))))
'(sb-c::check-ds-list)))) ; why does this remain in the IR?
(with-test (:name (dpb :eval-order :lp-1458190))
(sb-int:collect ((calls))
(flet ((f (new old)
(dpb (progn (calls 'eval-new) new)
(progn (calls 'eval-byte) (byte 10 10))
(progn (calls 'eval-old) old))))
(f 20 0)
(assert (equal (calls)
'(eval-new eval-byte eval-old))))))
;; Best practice treats TRULY-THE as a special operator, not a macro,
;; in a context such as (DPB X (TRULY-THE SB-KERNEL:BYTE-SPECIFIER ...) Y).
;; DPB used to expand its second argument using MACROEXPAND and lose
;; the nuance of TRULY-THE. Strictly speaking, byte-specifier is not a
;; type specifier that users are supposed to know about, so portable code
;; should not care, but this might affect internal code.
(with-test (:name (dpb :inner-macro))
(flet ((source-xform (sexpr)
(funcall (sb-int:info :function :source-transform (car sexpr))
sexpr (sb-kernel:make-null-lexenv))))
(assert (equal-mod-gensyms
(source-xform
'(dpb (new) (truly-the sb-kernel:byte-specifier bspec) (old)))
'(let ((new (new))
(byte (truly-the sb-kernel:byte-specifier bspec)))
(sb-kernel:%dpb new (byte-size byte) (byte-position byte)
(old)))))))
(with-test (:name :inline-satisfies-predicate)
;; If we remove the indirections in these functions,
;; this test should visibly break so that we can write a new test
;; that asserts that inlining F works in (THE (SATISFIES F) obj).
(assert (equal (sb-ext:typexpand 'sb-impl::function-name)
'(satisfies sb-int:legal-fun-name-p)))
(let ((f `(lambda (x) (the sb-impl::function-name x))))
(assert (equal (ctu:ir1-named-calls f) '(sb-int:valid-function-name-p))))
(let ((f `(lambda (x)
(declare (notinline sb-int:legal-fun-name-p))
(the sb-impl::function-name x))))
(assert (equal (ctu:ir1-named-calls f) '(sb-int:legal-fun-name-p)))))
(with-test (:name (make-array :untestable-type :no-warning))
(checked-compile `(lambda () (make-array '(2 2)
:element-type `(satisfies foofa)))))
(with-test (:name (make-array nil :no-warning))
(checked-compile '(lambda () (make-array '(2 2) :element-type nil))))
(with-test (:name (nth-value :huge-n :works))
(flet ((return-a-ton-of-values ()
(values-list (loop for i below (min 5000 (1- multiple-values-limit)) collect i))))
(assert (= (nth-value 1 (return-a-ton-of-values)) 1))
(let ((n (min 4000 (- multiple-values-limit 2))))
(assert (= (nth-value n (return-a-ton-of-values)) n)))))
(with-test (:name :internal-name-p :skipped-on :sb-xref-for-internals)
(assert (sb-c::internal-name-p 'sb-int:neq)))
(with-test (:name (:coerce-callable-to-fun :note))
(flet ((try (form what)
(multiple-value-bind (fun failure-p warnings style-warnings notes)
(checked-compile `(lambda (x)
(declare (optimize speed))
(funcall ,form)))
(declare (ignore fun failure-p warnings style-warnings))
(assert (search (format nil "~A is not known to be" what)
(princ-to-string (first notes)))))))
(try '(eval `(work-with ,x)) "callable expression")
(try 'x "X")
;; For this I'd accept either Z or X in the message.
(try '(progn (let ((z x)) (identity z))) "X")))
(with-test (:name (princ-to-string :unflushable))
;; Ordinary we'll flush it
(assert (not (ctu:ir1-named-calls '(lambda (x) (princ-to-string x) x))))
;; But in high safety it should be called for effect
(let ((f `(lambda (x)
(declare (optimize safety)) (princ-to-string x) x)))
(assert (equal (ctu:ir1-named-calls f) '(princ-to-string)))))
(with-test (:name :space-bounds-no-consing
:serial t
:skipped-on :interpreter)
;; Asking for the size of a heap space should not cost anything!
(ctu:assert-no-consing (sb-vm:%space-bounds :static))
(ctu:assert-no-consing (sb-vm:space-bytes :static)))
(with-test (:name (sb-vm:map-allocated-objects :no-consing)
:serial t
:fails-on (or :cheneygc (not :sb-thread))
:skipped-on :interpreter)
(let ((n 0))
(sb-int:dx-flet ((f (obj type size)
(declare (ignore obj type size))
(incf n)))
(ctu:assert-no-consing
(sb-vm:map-allocated-objects #'f :dynamic)
5))))
(with-test (:name :pack-varints-as-bignum
:skipped-on :interpreter) ; too slow
(dotimes (i 500) ; do some random testing this many times
(let* ((random-numbers (loop repeat (+ (random 20) 3)
collect (1+ (random 4000))))
(test-list (sort (delete-duplicates random-numbers) #'<))
(packed-int (sb-c:pack-code-fixup-locs test-list nil nil))
(result (make-array 1 :element-type '(unsigned-byte 32))))
(sb-sys:with-pinned-objects (packed-int result)
;; Now exercise the C unpacker.
;; This hack of allocating 4 longs is terrible, but whatever.
(let ((unpacker (make-alien word 4))
(prev-loc 0))
(alien-funcall (extern-alien "varint_unpacker_init"
(function void (* word) word))
unpacker
(sb-kernel:get-lisp-obj-address packed-int))
(sb-int:collect ((unpacked))
(loop
(let ((status
(alien-funcall
(extern-alien "varint_unpack"
(function int (* word) system-area-pointer))
unpacker (sb-sys:vector-sap result))))
(let ((val (aref result 0)))
;; status of 0 is EOF, val = 0 means a decoded value was 0,
;; which can't happen, so it's effectively EOF.
(when (or (eql status 0) (eql val 0)) (return))
(let ((loc (+ prev-loc val)))
(unpacked loc)
(setq prev-loc loc)))))
(assert (equal (unpacked) test-list))))))))
(with-test (:name (symbol-value symbol-global-value :quoted-constant))
(let ((f (checked-compile '(lambda () (symbol-value 'char-code-limit)))))
(assert (not (ctu:find-code-constants f :type 'symbol))))
(let ((f (checked-compile '(lambda () (symbol-global-value 'char-code-limit)))))
(assert (not (ctu:find-code-constants f :type 'symbol)))))
(with-test (:name (:set symbol-value :of defglobal))
(let ((s 'sb-c::*recognized-declarations*))
(assert (eq (sb-int:info :variable :kind s) :global)) ; verify precondition
(let ((f (checked-compile `(lambda () (setf (symbol-value ',s) nil)))))
;; Should not have a call to SET-SYMBOL-GLOBAL-VALUE>
(assert (not (ctu:find-code-constants f :type 'sb-kernel:fdefn))))))
(with-test (:name (:no style-warning :for inline :cl-fun))
(checked-compile '(lambda (x)
(declare (optimize (speed 3)) (inline length)
(muffle-conditions compiler-note))
(length x))))
(with-test (:name :deleted-return-use)
(checked-compile-and-assert ()
`(lambda ()
(block nil
(return 345)
(let ((a (catch 'x)))
(flet ((%f (a &optional b)
a))
(%f 0 (%f 123))))))
(() 345)))
(with-test (:name :shift-right-transform-nil-type)
(checked-compile-and-assert (:optimize nil)
`(lambda (b c)
(declare (type (integer -10 -6) c)
(optimize (debug 2)))
(catch 'c
(flet ((f1 (a &optional (b (shiftf b 0)) c d)
(declare (ignore a b c d))
(throw 'c 780)))
(flet ((f2 (a b)
(f1 a b 0)))
(ash
(f1 (if t
c
(f1 (f2 1 0) 0))
b)
(+ c))))))
((-3 -7) 780)))
(with-test (:name :move-lvar-result-through-unused-cast)
(checked-compile-and-assert (:optimize nil)
`(lambda ()
(declare (optimize (debug 0)))
(labels ((f (a b)
a b)
(x ()
(apply #'f (list 2 3))))
(declare (notinline f))
(the integer (x)))
132)
(() 132)))
(with-test (:name (:type-conflict funcall :external-lambda))
(compiles-with-warning `(lambda ()
(let ((x (lambda (x) (declare (fixnum x)) x)))
(funcall x 'a)))))
(with-test (:name (:type-conflict :callable :external-lambda))
(compiles-with-warning `(lambda ()
(let ((x (lambda (x) (declare (fixnum x)) x)))
(find-if x "abca")))))
(with-test (:name (:type-conflict map :result-type))
(compiles-with-warning `(lambda (str)
(map 'string (lambda (x) (declare (ignore x)) nil)
str))))
(with-test (:name (:type-conflict :by-name))
(compiles-with-warning `(lambda (str)
(map 'string 'evenp str))))
(with-test (:name (:type-conflict :callable :reporting))
(multiple-value-bind (fun failure-p warnings)
(checked-compile '(lambda (x) (map-into (make-string 10) #'evenp x))
:allow-warnings 'warning)
(declare (ignore fun))
(assert failure-p)
(assert (= (length warnings) 1))
(search "Derived type of EVENP is"
(princ-to-string (first warnings)))))
(with-test (:name (:type-conflict string :union-type))
(compiles-with-warning `(lambda (x)
(find-if #'evenp (the string x)))))
(with-test (:name (:type-conflict map-into :let))
(compiles-with-warning `(lambda (z)
(let ((x "abc"))
(map-into z #'evenp x)))))
(with-test (:name (:type-conflict map-into :result))
(compiles-with-warning `(lambda (z)
(map-into (make-string 10) #'evenp z))))
(with-test (:name (:type-conflict complement))
(compiles-with-warning
`(lambda (z)
(find z "l" :test (complement #'=)))))
(with-test (:name :type-across-hairy-lambda-transforms)
(assert (subtypep (sb-kernel:%simple-fun-type
(checked-compile `(lambda (x) (find 1 (the vector x)))))
'(function * (values (or (integer 1 1) null) &optional)))))
(with-test (:name :lea-type-derivation)
(checked-compile-and-assert ()
`(lambda (b)
(declare ((integer -3755795408964870057 -3391381516052960895)
b))
(ldb (byte 22 10) (* b 9)))
((-3391381516052980893) 2826685)))
(with-test (:name (:unused &optional :and &key))
(checked-compile-and-assert (:allow-style-warnings t)
`(lambda (&optional x &key)
(declare (ignore x))
10)
(() 10)))
(with-test (:name (:unknown values :coercion))
(checked-compile-and-assert ()
`(lambda (a)
(declare (notinline values typep))
(the integer (values a 2305843009213693946 a -207)))
((123) (values 123 2305843009213693946 123 -207))))
(with-test (:name :deleted-block-during-generate-type-checks)
(checked-compile-and-assert (:allow-warnings t)
`(lambda (a b)
(declare (notinline min ash conjugate oddp >=))
(if (and (or t (>= a)) (oddp 0))
(prog2 0
0
(labels ((f (a b c &key)
(declare (ignore a b c))
6965670824543402))
(f a 0 b)))
(conjugate
(dotimes (i 0 0)
(catch 'c
(ash
(the integer
(ignore-errors
(ignore-errors (throw 'c 1))))
(min a)))))))
((1 2) 0)))
(with-test (:name :block-delete-twice)
(checked-compile-and-assert ()
`(lambda ()
(declare (notinline >=))
(block nil
(lambda (x &key (key (if (>= 0 1)
(return (catch 'ct5 0)))))
(declare (ignore key))
x)))
(() 123 :test (lambda (values expected)
(equal (multiple-value-list
(funcall (first values) (first expected)))
expected)))))
(with-test (:name :dead-lvars-and-stack-analysis)
(checked-compile-and-assert ()
`(lambda (b)
(catch 'ct2
(block b5
(return-from b5
(multiple-value-prog1 19
(if (or b t)
(return-from b5 333)))))))
((11) 333)))
(with-test (:name :mv-call-more-values)
(checked-compile-and-assert ()
`(lambda (z)
(multiple-value-call (lambda (&optional x y &rest args)
(declare (ignore args))
(+ y x))
2 (truncate z 30)))
((2345) 80)))
(with-test (:name :unused-casts-at-ir2-convert)
(checked-compile-and-assert ()
`(lambda ()
(unwind-protect 123
(the integer
(labels ((%f (x &key)
(declare (ignore x))
(svref #(46 32) 0)))
(unwind-protect (%f (%f 0)))))))
(() 123)))
(with-test (:name :cmov-constants-different-primitive-type)
(checked-compile-and-assert ()
`(lambda (b)
(case b
((2030) 4611686018427387908)
((572) b)
(t 0)))
((572) 572)
((123) 0)
((2030) 4611686018427387908)))
(with-test (:name :mv-bind-skipping-vars-on-reoptimize)
(checked-compile-and-assert ()
`(lambda ()
(let (lv1)
(apply (lambda (&rest args)
(declare (ignore args)))
0
(list 3 lv1))
(setf lv1 10)))
(() 10)))
(with-test (:name :transform-on-a-nil-arg)
(checked-compile-and-assert ()
`(lambda ()
(block nil
(logtest
(multiple-value-prog1
(unwind-protect (return 32))
(catch 'tag (return 33)))
1)
34))
(() 32)))
(with-test (:name :nesteted-dx-deleted-uses)
(checked-compile-and-assert ()
`(lambda (a)
(block b2
(let* ((v1 (make-array nil :initial-element
(let ((a a))
(return-from b2 a)))))
(declare (dynamic-extent v1))
(aref v1))))
((342) 342)))
(with-test (:name :deleted-during-locall-analyze-fun-1)
(checked-compile-and-assert (:allow-warnings t)
`(lambda ()
(flet ((a ()))
(a 1)
(a 2)))
(() (condition 'program-error))))
(with-test (:name :delete-return-without-flush-dest)
(assert (eql
(catch 'c
(funcall (checked-compile
'(lambda ()
(labels ((%f () 40))
(multiple-value-prog1 *
(throw 'c (%f))
(%f)
30))))))
40)))
(with-test (:name :let-conversion-inside-deleted-lambda.1)
(checked-compile-and-assert ()
`(lambda ()
(block nil
(catch 'c)
(flet ((f (x &key)
(when x
(progv '(*) '(0)
(return)))))
(f (return 123))
(f 0))))
(() 123)))
(with-test (:name :let-conversion-inside-deleted-lambda.2)
(checked-compile-and-assert ()
`(lambda ()
(block nil
(block nil
(lambda () (return)))
(labels ((l () (l))
(%f (a &key)
(l)
(return a)))
(%f (return 321))
(%f 1))))
(() 321)))
(with-test (:name :assignment-conversion-inside-deleted-lambda)
(checked-compile-and-assert
(:allow-style-warnings t)
`(lambda (b)
(tagbody
(labels ((%f13 (&optional (f13-1 0) &key &allow-other-keys)
(declare (ignore f13-1))
b))
(if nil
(%f13 (go tag8))
(%f13)))
tag8))
((1) nil)))
(with-test (:name :nil-type-derived-before-assignment-conversion)
(checked-compile-and-assert ()
`(lambda (a)
(declare (ignore a))
(tagbody
(labels ((f (a)
(declare (ignore a))
(go tag1)))
(apply #'f 1 (list))
(apply #'f (catch 'ct (go tag1)) (list)))
tag1))
((1) nil)))
(with-test (:name :assignment-convert-untail-outside-calls)
(checked-compile-and-assert ()
`(lambda ()
(flet ((%f17 (&optional f17-1)
(declare (ignore f17-1))
(block block608
(block block606
(flet ((h0 ()
(return-from block606)))
(declare (dynamic-extent #'h0))
(return-from block608
(progn
(print #'h0 (make-broadcast-stream))
nil)))))))
(when nil (%f17))
(if t
(%f17)
(when nil
(%f17)))))
(() nil)))
(with-test (:name :assignment-convert-lambda-with-deleted-bind-block)
(checked-compile-and-assert ()
`(lambda ()
(flet ((%f5 ()
(flet ((%f2 (&optional (f2-2 (return-from %f5 1)))
0))
(let ((g624 1))
(cond ((eql g624 '1)
(%f2))
((eql g624 '2)
(%f2)))))))
0))
(() 0)))
(with-test (:name :unconvert-tail-calls)
(checked-compile-and-assert ()
`(lambda ()
(block nil
(labels ((f (&optional (a (return))
(b (if t (return)))
c
&rest args)
(declare (ignore a b c args))
(return 0)))
(let (x)
(equal 10 (f 0 3))
(f 123 0 0)
(f 0)
x))))
(() 0)))
(with-test (:name :deleting-exits-with-multiple-users)
(checked-compile-and-assert ()
`(lambda (a b)
(block nil
(multiple-value-prog1 b
(tagbody (return (multiple-value-prog1 3
(if a (go z)))) z))))
((nil :good) 3)
((t :good) :good)))
(with-test (:name :merge-tail-sets-deleted-functional)
(checked-compile-and-assert ()
`(lambda (a)
(block nil
(tagbody
(go g549)
g549
(return-from nil
(block b3
(let ((x (progn (lambda (&optional (x a)) x)
(unwind-protect 10)
(return-from b3 a))))
(unwind-protect x)))))))
((321) 321)))
(with-test (:name :float-remainders-rounding-errors)
(loop for fun in '(ceiling truncate floor
fceiling ftruncate ffloor
round fround)
do
(assert (member (second
(third (sb-kernel:%simple-fun-type
(checked-compile
`(lambda (x)
(nth-value 1 (,fun (the double-float x) 1/2)))))))
'(double-float real)))))
(with-test (:name :complex-float-contagion)
(checked-compile-and-assert ()
`(lambda (p1)
(declare (type (or double-float integer) p1))
(complex p1 2.0))
((1d0) #c(1d0 2d0))))
(with-test (:name :equal-transform-member-types)
(let* ((s1 "abc")
(s2 (copy-seq s1)))
(checked-compile-and-assert ()
`(lambda (p1 p2)
(declare (type (member ,s1) p1)
(type (member ,s2 #*10) p2))
(equal p1 p2))
((s1 s2) t))))
(with-test (:name :equalp-transform-numeric-types)
(checked-compile-and-assert ()
`(lambda (p1 p2)
(declare (type (or fixnum list) p1)
(type double-float p2))
(equalp p1 p2))
((1 1d0) t)))
(with-test (:name :equalp-transform-zero-array)
(checked-compile-and-assert ()
`(lambda (a b)
(declare (simple-string a)
(simple-bit-vector b))
(equalp a b))
(("" #*) t)))
(with-test (:name :equalp-transform-zero-string)
(checked-compile-and-assert
()
`(lambda (a)
(equalp "" a))
((#*) t)
((#()) t)))
(with-test (:name :fill-transform-returning-array-data)
(let ((vector (make-array 10 :fill-pointer 2)))
(checked-compile-and-assert ()
`(lambda (v)
(declare (type (vector t) v))
(fill v nil))
((vector) vector))))
(with-test (:name :missing-error-context)
(flet ((run ()
(let ((string
(with-output-to-string (*error-output*)
(compile nil '(sb-int:named-lambda bob () (otherfun) 3)))))
(assert (search "in: SB-INT:NAMED-LAMBDA BOB" string)))))
(run)
;; Unrepeatability is confusing:
;; The first compiler invocation used to leave *last-format-string*
;; with a toplevel value, so the second would not print enough context
;; because the format control and args were the same.
(run)))
(with-test (:name :cast-deletion-notes)
(checked-compile-and-assert
(:allow-notes nil)
`(lambda (m)
(setf m (list 1 2 3))
(the simple-vector
(coerce m 'vector)))
((nil) #(1 2 3) :test #'equalp)))
(with-test (:name :cast-deletion-notes.2)
(multiple-value-bind (fun fail warn style notes)
(checked-compile
`(lambda (m)
(setf m (list 1 2 3))
(the simple-vector
(if (vectorp m)
m
#(1)))))
(declare (ignore fail warn style))
(assert (equalp (funcall fun nil)
#(1)))
(assert (= (length notes) 1))
(assert (typep (car notes) 'code-deletion-note))))
(with-test (:name :array-call-type-deriver)
(checked-compile-and-assert
()
`(lambda (vector)
(funcall (the (function (t t)) #'aref)
vector
0))
(((vector 333)) 333)))
(with-test (:name :function-designator-cast-removal)
(let ((fun (checked-compile
`(lambda (vectors x)
(declare (list vectors x))
(map 'list #'svref vectors x)))))
(assert (notany (lambda (c)
(typecase c
(sb-kernel:fdefn
(eq (sb-c::fdefn-name c) 'svref))
(function
(eq c #'svref))))
(ctu:find-code-constants fun)))
(assert (equal (funcall fun '(#(44)) '(0)) '(44)))))
(with-test (:name :zombie-casts)
(checked-compile-and-assert
()
`(lambda ()
(flet ((f (a b)
(declare (ignore a))
b))
(multiple-value-call #'f
(values (the integer (unwind-protect (f 10 20)))
322))))
(() 322)))
(with-test (:name :zombie-casts.2)
(let ((sb-c::*max-optimize-iterations* 1))
(checked-compile-and-assert
()
`(lambda (a b)
(declare (type fixnum a b))
(elt '(167992664 119771479)
(max 0
(catch 'ct2
(if (typep b '(integer -52))
a
0)))))
((1 2) 119771479))))
(with-test (:name :find-dfo-on-deleted-lambda)
(assert (= (funcall
(funcall (checked-compile
`(lambda ()
(declare (notinline <))
(block nil
(lambda (&key (key
(unwind-protect
(if (< 0)
34
(return (catch 'c))))))
key))))))
34)))
(with-test (:name :ir1-ir2-dead-code-consistency)
(checked-compile-and-assert
()
`(lambda ()
(loop for x below 2
count (zerop (min x x x x x x x x x x))))
(() 1)))
(with-test (:name :ir1-ir2-dead-code-consistency)
(checked-compile-and-assert
()
`(lambda ()
(loop for x below 2
count (zerop (min x x x x x x x x x x))))
(() 1)))
(with-test (:name (setf svref :constant-modification))
(assert
(= (length (nth-value 2
(checked-compile
`(lambda (x)
(setf (svref #(a b c) 1) x))
:allow-warnings 'sb-int:constant-modified)))
1)))
(with-test (:name (debug :constant-modification))
(assert
(= (length (nth-value 2
(checked-compile
`(lambda (x)
(declare (optimize (debug 2)))
(let ((m "abc"))
(delete x m)))
:allow-warnings 'sb-int:constant-modified)))
1)))
(with-test (:name (debug :constant-modification.2))
(assert
(= (length (nth-value 2
(checked-compile
`(lambda (x)
(declare (optimize (debug 2)))
(let ((m (if x
"abc"
"fgh")))
(delete x m)))
:allow-warnings 'sb-int:constant-modified)))
1)))
(with-test (:name (debug :unused-tn-long-arglist))
(checked-compile-and-assert
()
`(lambda (n x)
(declare (sb-vm:word n))
(log (float n))
(nth-value 33 (funcall x . #.(loop for i to 35 collect i))))
((10 (lambda (&rest args) (values-list args))) 33)))
(with-test (:name (debug :unused-tn-very-long-arglist))
(checked-compile-and-assert
()
`(lambda (n x)
(declare (sb-vm:word n))
(log (float n))
(nth-value 33 (funcall x . #.(loop for i to (min 350 (- multiple-values-limit 2))
collect i))))
((10 (lambda (&rest args) (values-list args))) 33)))
(with-test (:name (dynamic-extent :recursive-local-functions))
(checked-compile
`(lambda ()
(let ((s (labels ((%f () (%f)))
(%f))))
(declare (dynamic-extent s))
(car s)))))
(with-test (:name (:ctypep :hairy-types))
(checked-compile
`(lambda ()
(the (cons (satisfies error)) '("a"))))
(assert
(nth-value 3
(checked-compile
`(lambda () (the (array abc) #()))
:allow-style-warnings t))))
(with-test (:name (catch :evaluate-tag-before-%catch))
(checked-compile-and-assert
(:allow-style-warnings t)
`(lambda (z)
(catch (multiple-value-call #'+
(if z 1 (values 1 2)))
:done))
((t) :done)
((nil) :done)))
(with-test (:name :nested-catch-progv-compile)
(checked-compile
`(lambda (a b)
(catch 'ct
(flet ((f (x &key) x (throw 'ct b)))
(dotimes (i 1)
(if (< (progv '() (f a) 1) a)
a
(catch 'ct (f a)))))))))
(with-test (:name (tagbody :tag-dynamic-extent))
(checked-compile-and-assert
(:optimize '(:safety 3 :debug 2))
`(lambda (b)
(declare (optimize (safety 3) (debug 2)))
(tagbody
(labels ((f (x &key) x (go tag6)))
(tagbody
(catch 'ct2 (f b))
2)
(dotimes (i 1) (f 1))
-1)
tag6))
((1) nil)))
(with-test (:name :fewer-cast-conversions)
(multiple-value-bind (fun failed)
(checked-compile
`(lambda ()
(let* ((v (cons 0 (catch 'ct (the integer nil)))))
(declare (dynamic-extent v))
(flet ((%f (x) x))
(%f (cdr v)))))
:allow-warnings t)
(assert failed)
(handler-bind ((error (lambda (c) c (throw 'ct 33))))
(assert (= (funcall fun) 33)))))
(with-test (:name :constant-folding-with-callable-args)
(checked-compile '(lambda () (count #'%f '(a)))
:allow-style-warnings t))
(with-test (:name :flushable-with-callable-args)
(assert (not (ctu:ir1-named-calls
'(lambda (y) (let ((x (count y '(1 2 3))))
(declare (ignore x))))))))
(with-test (:name (remove :count))
(checked-compile-and-assert
()
`(lambda (x)
(remove x "aaa" :count 2))
((#\a) "a"))
(checked-compile-and-assert
()
`(lambda (x)
(remove-if (lambda (y) (eql y x)) "aaa" :count 2))
((#\a) "a")))
(with-test (:name (:constant-fold :allow-other-keys))
(checked-compile-and-assert
()
`(lambda (x)
(reduce #'+ '(1 2 3) :allow-other-keys t :bad x))
((1) 6)))
(with-test (:name (:constant-fold :allow-other-keys.2))
(checked-compile-and-assert
()
`(lambda (x)
(reduce #'+ '(1 2 3) :allow-other-keys x))
((1) 6)))
(with-test (:name (:constant-fold :repeat-keys))
(checked-compile-and-assert
()
`(lambda (x)
(member nil '(1 2 3) :key #'evenp :key x))
((1) '(1 2 3) :test #'equal)))
(with-test (:name :function-and-instance-primitive-type)
(checked-compile-and-assert
()
`(lambda (f)
(declare (function f))
(the standard-object f)
(funcall f #'list t))
((#'documentation) (documentation #'list t))))
(with-test (:name :mv-call-safety-0)
(checked-compile-and-assert
()
`(lambda (a)
(flet ((%f1 (x y) (+ x y)))
(apply #'%f1 a (list 0))))
((3) 3)))
(with-test (:name :cast-type-check-external)
(checked-compile-and-assert
()
`(lambda (x)
(declare (notinline +))
(gcd
(loop for lv2 below 1
count (logbitp 0
(if x
(return x)
1)))
0))
((334) 334)))
(with-test (:name :flush-combination-non-fun-type)
(checked-compile-and-assert
()
`(lambda ()
(rassoc-if-not #'values '((1 . a)) :allow-other-keys t)
1)
(() 1)))
(with-test (:name :symeval-nil)
(checked-compile-and-assert
()
`(lambda ()
(symbol-value nil))
(() nil)))
(with-test (:name (:environment-analyze :deleted-lambda))
(checked-compile-and-assert
()
`(lambda (log)
(loop for str in nil
for i from 0
do
(ignore-errors (format log ""))))
((t) nil)))
(with-test (:name (:ensure-lvar-fun-form :lvar-uses))
(checked-compile-and-assert
()
`(lambda (op) (funcall (case op (equal '=) (t '=)) 1 2))
(('equal) nil)
((t) nil)))
(with-test (:name :substitute-let-funargs-during-find-initial-dfo)
(checked-compile
`(lambda ()
(labels ((%r (f)
(loop)
(%r f)))
(%r (lambda ()))))))
(with-test (:name :split-ir2-blocks-cmov)
(checked-compile-and-assert
()
`(lambda ()
(let ((v (list 0)))
(if (block nil
(eq v (cdr v)))
1
2)))
(() 2)))
(with-test (:name :=-rational-complex-rational-fold)
(let ((fun (checked-compile '(lambda (x)
(declare ((complex integer) x))
(= x 10))))
(fun2 (checked-compile '(lambda (x)
(declare ((complex rational) x))
(= x 10d0)))))
(assert (equal (sb-kernel:%simple-fun-type fun)
'(function ((complex rational)) (values null &optional))))
(assert (not (funcall fun #C(10 10))))
(assert (equal (sb-kernel:%simple-fun-type fun2)
'(function ((complex rational)) (values null &optional))))
(assert (not (funcall fun2 #C(10 10))))))
(with-test (:name (:numeric float rational :contagion))
(flet ((check (operator type argument)
(let ((fun (checked-compile
`(lambda (x)
(declare (type ,type x))
,(ecase argument
(1 `(,operator x 1/2))
(2 `(,operator 1/2 x)))))))
(assert (null (ctu:find-code-constants fun :type 'ratio))))))
(dolist (operator '(+ * / - = < > <= >=))
(dolist (type '(single-float double-float))
(check operator type 1)
(check operator type 2)
(when (member operator '(+ * / - =))
(check operator `(complex ,type) 1)
(check operator `(complex ,type) 2))))))
(with-test (:name (:numeric float float :contagion))
(flet ((check (operator type argument)
(let ((fun (checked-compile
`(lambda (x)
(declare (type ,type x))
,(ecase argument
(1 `(,operator x 1.0f0))
(2 `(,operator 1.0f0 x)))))))
(assert (null (ctu:find-code-constants fun :type 'single-float))))))
(dolist (operator '(+ * / - = < > <= >=))
(check operator 'double-float 1)
(check operator 'double-float 2)
(when (member operator '(+ * / - =))
(check operator '(complex double-float) 1)
(check operator '(complex double-float) 2)))))
(with-test (:name :find-type-deriver)
(checked-compile-and-assert
()
`(lambda (x)
(find 1 x :key #'values))
(('(1)) 1)))
(with-test (:name :tail-call-ltn-annotation)
(checked-compile-and-assert
()
`(lambda (x)
(labels ((ff1 ()
(multiple-value-call #'print
(if x
(values t t)
nil))
(ff1)))
(identity (ff1))))))
(with-test (:name (:substitute-lvar-uses :deleted-code-and-dx-lvars))
(assert (nth-value 1
(checked-compile
`(lambda ()
(let ((v (values
(the integer
(flet ((%f5 (x) x))
(%f5)))
(unwind-protect 1))))
(declare (dynamic-extent v))
v))
:allow-warnings t))))
(with-test (:name (restart-case :declaration-processing))
(checked-compile-and-assert
()
`(lambda ()
(restart-case (list)
(my-restart (x) "foo" "bar" x)))
(() ()))
(checked-compile-and-assert
()
`(lambda ()
(restart-case (list)
(my-restart () (declare))))
(() ())))
(with-test (:name (handler-case :declaration-processing))
(checked-compile-and-assert
()
`(lambda ()
(handler-case (list 1 2) (error (e) "foo" "bar" e)))
(() '(1 2)))
(assert (nth-value 1
(checked-compile
`(lambda ()
(handler-case (declare)))
:allow-failure t))))
(with-test (:name (:unconvert-tail-calls :deleted-call))
(assert (nth-value 1
(checked-compile
'(lambda ()
(labels ((%f (&optional (x (* 2 nil (%f)))) x))
(%f)
(%f 1)))
:allow-warnings t))))
(with-test (:name (:equal-transform :nil-types))
(assert (nth-value 1
(checked-compile
'(lambda ()
(loop for y below 3
count (or
(not (or (>= y y) (equal y -787357528)))
(the integer (or (>= y y) (equal y -787357528))))))
:allow-warnings t))))
(with-test (:name (:delete-recursive-optional))
(checked-compile '(lambda (x)
(lambda ()
(labels ((f (&optional a) (values x a #'f))))))))
(with-test (:name (:combination-args-flow-cleanly-p :unused-result))
(checked-compile-and-assert
()
`(lambda ()
(let ((v (flet ((%f (x)
(list x)
(list 1)))
(%f 2))))
(declare (dynamic-extent v))
(car v)))
(() 1)))
(with-test (:name (:delete-ref :maintain-lambda-calls-or-closes))
(checked-compile `(lambda (c y)
(labels ((f1 ()
(if y
(f3 2)))
(l () (loop))
(f2 ()
(l)
(f3 3))
(f3 (x)
(f3 x))
(f4 ()
(f1)
(f2)))
(f4)
c))))
(with-test (:name (the :nil-type))
(checked-compile
`(lambda ()
(flet ((f () (the nil 0)))
(oddp (f))))))
(with-test (:name :concatenate-transform-hairy-type)
(checked-compile
'(lambda (x)
(concatenate '(and string (satisfies eval)) x))))
(with-test (:name :make-array-transform-deletion-notes)
(checked-compile
`(lambda (vector)
(let* ((length (length vector))
(new (make-array length :adjustable t
:fill-pointer length)))
new))
:allow-notes nil))
(with-test (:name :ltn-analyze-cast-unlink)
(assert (nth-value 1 (checked-compile
`(lambda (n)
(* 2 n)
(let ((p (make-array n :element-type 'double-float)))
(dotimes (i n)
(setf (aref p i)
(ignore-errors i)))))
:allow-warnings t))))
(with-test (:name :call-type-validation)
(checked-compile
`(lambda ()
(funcall (the (or cons function) *debugger-hook*)))))
(with-test (:name :setf-schar-hairy-types)
(checked-compile-and-assert
()
`(lambda (s v)
(setf (schar (the (satisfies eval) s) 0) v)
s)
(((copy-seq "abc") #\m) "mbc" :test #'equal)))
(with-test (:name :replace-zero-elements)
(checked-compile-and-assert
()
'(lambda (x)
(declare ((simple-vector 2) x))
(replace x x :start1 2))
(((vector 1 2)) #(1 2) :test #'equalp))
(checked-compile-and-assert
()
'(lambda (x)
(replace x x :start1 2))
(((vector 1 2)) #(1 2) :test #'equalp)))
(with-test (:name :error-in-xep)
(checked-compile-and-assert
(:optimize :safe)
'(lambda (x)
(declare (type (satisfies error) x))
x)
(("") (condition 'error))))
(with-test (:name :lifetime-analyze-tn-overflow-unused-tns)
(checked-compile-and-assert
()
`(lambda (x)
(multiple-value-bind (a b c)
(funcall x 1 2 3 ,@(make-list 58))
(declare (ignore b))
(values a c)))
((#'values) (values 1 3))))
(with-test (:name :constraints-not-enough-args)
(checked-compile-and-assert
()
`(lambda (list)
(delete-if #'> (the list list)))
(((list 1)) nil)))
(with-test (:name :%coerce-callable-for-call-removal-order-mv-call)
(checked-compile-and-assert
()
`(lambda (fun args)
(loop
(let ((result (apply fun args)))
(when result
(return result))
(setf args result))))
(('list '(1)) '(1) :test #'equal)))
(with-test (:name :constraint-loop)
(checked-compile-and-assert
()
`(lambda (a b)
(check-type a list)
(when a
(mapcar #'identity a)
(loop for c from 0 do (loop for d in b do
(loop for e in a)))))))
(with-test (:name :primitive-type-fun-designator)
(checked-compile-and-assert
()
`(lambda (fun)
(map 'vector fun '(1 2 3)))
(('1+) #(2 3 4) :test #'equalp)))
(with-test (:name :mv-call-lambda-type-derivation)
(assert
(equal (sb-kernel:%simple-fun-type
(checked-compile
'(lambda (x)
(multiple-value-call
(lambda () 133)
(funcall x)))))
'(function (t) (values (integer 133 133) &optional)))))
(with-test (:name :mv-call-lambda-type-derivation.closure)
(assert
(equal (sb-kernel:%simple-fun-type
(checked-compile
'(lambda (x)
(multiple-value-call
(lambda () (print x) 133)
(funcall x)))))
'(function (t) (values (integer 133 133) &optional)))))
(with-test (:name :constant-folding-and-hairy-types)
(checked-compile-and-assert
()
'(lambda ()
(> 0 (the (satisfies eval) (- 1))))
(() t)))
(with-test (:name :type-approximate-interval-and-hairy-types)
(checked-compile-and-assert
()
'(lambda (x)
(declare (fixnum x))
(<= (the (satisfies eval) 65) x))
((66) t)))
(with-test (:name :remove-equivalent-blocks-constraints)
(checked-compile-and-assert
()
`(lambda (c)
(declare (integer c))
(= (case c
((-10) (abs c))
(t c))
-1))
((-1) t)))
(with-test (:name :typep-singleton-intersect-types)
(checked-compile-and-assert
()
`(lambda ()
(keywordp t))
(() nil)))
(with-test (:name :constants-and-cmp)
(checked-compile-and-assert
()
'(lambda (l)
(declare (fixnum l))
(let ((v 0))
(labels ((change ()
(setf v 10)
#'change))
(> v l))))
((1) nil))
(checked-compile-and-assert
()
'(lambda (l)
(declare (fixnum l))
(let ((v 0))
(labels ((change ()
(setf v 10)
#'change))
(> l v))))
((1) t)))
(with-test (:name :inlining-and-substituted-block-lvars)
(checked-compile-and-assert
()
`(lambda ()
(let ((z (block nil
(labels ((f (x)
(return x)))
(declare (inline f))
(funcall (the function #'f) t)
(funcall (the function #'f) t)))))
(and z
1)))
(() 1)))
(with-test (:name :inlining-reanlyzing-optionals)
(checked-compile-and-assert
()
`(lambda ()
(labels ((w (x)
x
#'s)
(fun2 (f x)
(funcall f x))
(s (&optional x)
(fun2 #'w x)))
(declare (inline w))
(s)))))
(with-test (:name :vector-fill/t-fast-safe)
(let ((sb-c::*policy-min* sb-c::*policy-min*))
(sb-ext:restrict-compiler-policy 'safety 1)
(checked-compile-and-assert
()
'(lambda ()
(make-array 2 :initial-element 10))
(() #(10 10) :test #'equalp))))
(with-test (:name :deleted-tail-sets)
(checked-compile-and-assert
()
'(lambda ()
(labels ((f (&optional (a (catch t 6))
(b (error ""))
(c (unwind-protect 1)))
(+ a b c)))
(unwind-protect (f 4))))
(() (condition 'error))))
;;; The SLEEP source transform barfed on float positive infinity
;;; values.
(with-test (:name (compile sleep float :infinity :lp-1754081))
(checked-compile '(lambda () (sleep single-float-positive-infinity)))
(checked-compile '(lambda () (sleep double-float-positive-infinity))))
;;; And it didn't work at all after the fix for aforementioned
(with-test (:name :sleep-float-transform
:skipped-on (and :win32 (not :sb-thread)))
(let* ((xform (car (sb-c::fun-info-transforms (sb-int:info :function :info 'sleep))))
(type (car (sb-kernel:fun-type-required (sb-c::transform-type xform)))))
(assert (sb-kernel:constant-type-p type))
;; CONSTANT-TYPE isn't actually testable through CTYPEP.
;; So pull out the actual type as the compiler would do.
(assert (sb-kernel:ctypep 1.5 (sb-kernel:constant-type-type type)))))
(with-test (:name :atanh-type-derivation)
(checked-compile-and-assert
()
'(lambda (x)
(atanh (coerce x '(double-float * (0.0d0)))))))
(with-test (:name :ir1-optimize-combination-unknown-keys)
(checked-compile-and-assert
()
'(lambda (p x y)
(let ((f (when p #'string-equal)))
(when f
(funcall f "a" "b" x y))))
((t :start1 0) nil)))
(with-test (:name :member-transform)
(let ((list '(2 1 3)))
(checked-compile-and-assert
()
'(lambda (list &key key)
(member 1 list :key key))
((list) (cdr list)))))
(with-test (:name :note-no-stack-allocation-casts)
(checked-compile-and-assert
()
`(lambda ()
(let ((*s* (the integer (catch 'ct1 0))))
(declare (dynamic-extent *s*)
(special *s*))))))
(with-test (:name :dxify-downward-funargs-variable-name)
(checked-compile-and-assert
()
'(lambda () ((lambda (map) (funcall map)) #'list))))
(with-test (:name :dxify-downward-funargs-malformed)
(checked-compile
'(lambda () (sb-debug:map-backtrace))
:allow-style-warnings t))
(with-test (:name :dxify-downward-funargs-casts)
(checked-compile-and-assert
()
'(lambda (f x)
(flet ((f (y) (funcall f y)))
(funcall (the (satisfies eval) #'every) #'f x)))
((#'evenp '(2 2 4)) t)))
(with-test (:name :array-call-type-deriver-non-fun-type)
(checked-compile-and-assert
()
'(lambda (x) (funcall (the compiled-function #'aref) x))
((#0A123) 123)))
(with-test (:name :nth-&rest-overflow)
(checked-compile-and-assert
()
'(lambda (&rest s) (nth 536870908 s))
(() nil)))
(with-test (:name :array-in-bounds-p-transform-hairy-types)
(checked-compile-and-assert
()
'(lambda ()
(let ((a (the (satisfies eval) (make-array 4 :fill-pointer 0))))
(and (array-in-bounds-p a 0)
(array-in-bounds-p a 1))))
(() t)))
(with-test (:name :array-type-dimensions-or-give-up-hairy-types)
(checked-compile-and-assert
()
'(lambda (a i)
(declare ((or (array * (1)) (satisfies eval)) a))
(array-row-major-index a i))
((#(a b) 1) 1)))
(with-test (:name :array-type-dimensions-0-rank)
(checked-compile-and-assert
()
'(lambda (p1)
(declare ((or (array bit 1) (array * 0)) p1))
(array-total-size p1))
((#0a3) 1)))
(with-test (:name :type-derivation-hairy-types)
(checked-compile-and-assert
()
`(lambda (n s)
(declare (fixnum n))
(ash (the (satisfies eval) n)
(the (integer * 0) s)))
((1234 -4) 77))
(checked-compile-and-assert
()
`(lambda (p)
(declare (type (member #c(0.5d0 4.0d0) #c(0 -1)) p))
(/ (the (satisfies eval) p)))
((#c(0 -1)) #C(0 1))))
(with-test (:name :assert-lvar-type-intersection)
(checked-compile-and-assert
()
`(lambda (x y)
(write-sequence nil (the standard-object x) y nil))))
(with-test (:name :or-bignum-single-float-no-notes
:skipped-on (not (or :arm64 ppc :x86 :x86-64)))
(checked-compile
'(lambda (x) (declare (optimize speed)) (typep x '(or bignum single-float)))
:allow-notes nil))
(with-test (:name :vertices-best-color/general-default-value)
(checked-compile-and-assert
()
`(lambda (a)
(declare ((simple-array (complex double-float)) a))
(* (aref a 0)
(let ((z (aref a 0)))
(complex (realpart z) (imagpart z)))))))
(with-test (:name :copy-list-inlined)
(let ((f (checked-compile
`(lambda (x) (declare (optimize speed)) (copy-list x)))))
;; Should not have a call to COPY-LIST (or anything)
(assert (not (ctu:find-code-constants f :type 'sb-kernel:fdefn)))))
(with-test (:name :move-from-fixnum+-1)
(checked-compile-and-assert
(:allow-notes nil)
`(lambda (x)
(declare (fixnum x))
(1- x))
((0) -1)
((most-positive-fixnum) (1- most-positive-fixnum))
((most-negative-fixnum) (1- most-negative-fixnum)))
(checked-compile-and-assert
(:allow-notes nil)
`(lambda (x)
(declare (fixnum x))
(1+ x))
((0) 1)
((most-positive-fixnum) (1+ most-positive-fixnum))
((most-negative-fixnum) (1+ most-negative-fixnum)))
(checked-compile-and-assert
(:allow-notes nil)
`(lambda (a x)
(declare (fixnum x))
(if a
10
(1+ x)))
((nil 0) 1)
((t 0) 10)
((nil most-positive-fixnum) (1+ most-positive-fixnum))
((nil most-negative-fixnum) (1+ most-negative-fixnum))))
(with-test (:name :coalesce-more-ltn-numbers-constants)
(checked-compile-and-assert
()
`(lambda (x)
(list 1 1 ,@(make-list 100 :initial-element 'x)))
((1) (make-list 102 :initial-element 1) :test #'equal)))
(with-test (:name (:lambda-var-ref-lvar :multiple-refs))
(checked-compile-and-assert
()
`(lambda (vector index)
(labels ((update (index)
(let ((old (svref vector index)))
(if (eq old 10)
(update index)
old)))
(wrap (index)
(update index)))
(wrap index)))
((#(1 2 3) 1) 2)))
(with-test (:name :string-type-unparsing)
(checked-compile-and-assert
()
`(lambda (s)
(declare (type (string 1) s))
(the (or simple-array (member 1/2 "ba" 0 #\3)) s))
((#1="a") #1#)))
(with-test (:name :primitive-type-function)
(checked-compile-and-assert
()
`(lambda (x)
(funcall (the (and atom (not null)) x))
)
((#'list) nil)
(('list) nil)))
(with-test (:name :copyprop-sc-mismatch-between-moves
:serial t
:skipped-on :interpreter)
(let ((f (checked-compile
'(lambda (f x)
(let ((x (the double-float x)))
(values (funcall f x) (> x 1d0)))))))
(ctu:assert-no-consing (funcall f #'identity 1d0))))
(with-test (:name (:infer-iteration-var-type :step-is-range))
(let ((f (checked-compile
'(lambda (s)
(declare ((integer 1 2) s))
(let ((r 16))
(loop for i from 16 below 32 by s
do (setf r i))
r)))))
(assert (equal (sb-impl::%simple-fun-type f)
'(function ((integer 1 2)) (values (integer 16 31) &optional))))))
(with-test (:name (:infer-iteration-var-type :multiple-sets))
(let ((f (checked-compile
'(lambda (x)
(declare (optimize speed)
(type (integer 3 10) x))
(let ((y x))
(tagbody
:start
(when (plusp y)
(decf y)
(when (plusp y)
(decf y)
(go :start))))
y))
:allow-notes nil)))
(assert (equal (sb-impl::%simple-fun-type f)
'(function ((integer 3 10)) (values (integer 0 0) &optional))))))
(with-test (:name (:infer-iteration-var-type :incompatible-sets))
(checked-compile-and-assert ()
'(lambda (input-total missing-amount)
(declare (fixnum input-total) (fixnum missing-amount))
(loop with tot = 0
repeat 1
do (let ((difference input-total))
(setq difference (max difference 0))
(setq tot (+ tot difference)))
finally (when (plusp missing-amount)
(decf tot missing-amount))
(return (if (plusp tot) :good :bad))))
((0 0) :bad)
((1 0) :good)
((0 1) :bad)
((1 1) :bad)))
(with-test (:name :delay-transform-until-constraint-loop)
(checked-compile-and-assert
()
`(lambda (str)
(declare (string str))
(when (plusp (length str))
(make-array (1- (length str))
:element-type (array-element-type str)
:displaced-to str)))
(("abc") "ab" :test #'equal)))
(with-test (:name :lambda-var-ref-lvar-loop)
(checked-compile-and-assert
()
`(lambda ()
(labels ((z (a)
(when (>= 0 (the integer a))
(values #'z a))))))
(() nil)))
(with-test (:name :vector-length-fill-pointer-type-derivation)
(checked-compile-and-assert
()
`(lambda (s)
(= (length (the (string 1) s)) 1))
(((make-array 1 :element-type 'character :fill-pointer 0)) nil)))
(with-test (:name :function-designator-loop)
(checked-compile-and-assert
()
`(lambda (p1 p3 p4)
(declare (type (or (eql #.#'oddp)
(satisfies eval)) p1))
(find-if-not p1 nil p3 p4))
((#'oddp :from-end t) nil)))
(with-test (:name :lvar-constants-nested-funs)
(checked-compile-and-assert
()
`(lambda (x)
(labels ((f (x &optional result)
(if x
(f x result)
(nreverse result))))
(f x)))
((nil) nil)))
(with-test (:name :nested-indirect-var-fp-coalescence)
(checked-compile-and-assert
()
`(lambda ()
(let ((x 1)
(j 2))
(labels ((m ()
(incf x 32)
(incf j 44)
(let ((z 1))
(labels ((m ()
(incf x 32)
(incf z)))
(declare (notinline m))
(m)
(incf j z)))))
(declare (notinline m))
(m)
(values x j))))
(() (values 65 48))))
(with-test (:name :non-returning-functions-conflict)
(checked-compile-and-assert
()
`(lambda (x) (map nil #'error x))
((nil) nil)))
(with-test (:name :array-typep-other-pointer-widetag)
(checked-compile-and-assert
()
`(lambda (x)
(typep x '(and base-string (not simple-array))))
((10) nil)
(((make-array 10 :element-type 'base-char :adjustable t)) t)))
(with-test (:name :constraint-after-checkgen)
(let ((v #(10 20)))
(checked-compile-and-assert
()
`(lambda (p1 p2 p3 p4)
(declare (type (satisfies eval) p2)
(type (member :from-end 2) p3))
(position p1
(the (member ,v 3) p2)
(the (member 1 :from-end) p3) nil
:test-not p4))
((20 v :from-end #'/=) 1))))
(with-test (:name :cast-multiple-uses-no-dest)
(checked-compile-and-assert
(:allow-style-warnings t)
`(lambda (x)
(the integer
(when x
(if (> x 0) 1 2)))
(the integer x))
((23) 23))
(checked-compile-and-assert
(:allow-style-warnings t)
`(lambda (a b)
(declare (optimize (debug 1)))
(logand
(when b
(if (> (the integer a) 0) 10 20))
0)
(the integer b))
((24 23) 23)))
(with-test (:name :maybe-delete-exit-after-let-conversion)
(checked-compile-and-assert
()
`(lambda (m)
(flet ((out ()
(flet ((in (a)
(dotimes (i 3 a)
(if m
(return-from out)
(return-from out)))
(labels ((f (&optional (a m))
a
m)))))
(in (in 10)))))
(out)
33))
((t) 33))
(checked-compile-and-assert
()
`(lambda ()
(unwind-protect
(flet ((f (a b &optional c)
(values a b c)))
(f 1 2 (f 0 0)))))
(() (values 1 2 0))))
(with-test (:name :make-array-hairy-cons)
(checked-compile-and-assert
()
`(lambda (type)
(make-array 4 :element-type type :initial-element 0))
(('(or (cons (satisfies eval)) atom)) #(0 0 0 0) :test #'equalp)))
(with-test (:name :substitute-single-use-lvar-exit-cleanups)
(checked-compile-and-assert
()
`(lambda (z)
(block nil
(let ((b (1+ (funcall z))))
(catch 'c (return b)))))
(((constantly 33)) 34)))
(with-test (:name :substitute-single-use-lvar-unknown-exits)
(checked-compile-and-assert
()
`(lambda (f)
(block nil
(let ((x (evenp (funcall f)))
(y (catch 'c
(return (catch 'c (block nil 11))))))
(declare (ignore y))
x)))
(((constantly 33)) 11)))
(with-test (:name :substitute-single-use-lvar-unknown-exits.2)
(checked-compile-and-assert
()
`(lambda (b)
(block nil
(if (catch 'c 0)
(return
(let ((x (the real b)))
(let ((* (list 1)))
(declare (dynamic-extent *))
(catch 'ct5
(if t (return 34))))
x))
(catch 'c 0))))
((1) 34)))
(with-test (:name :substitute-single-use-lvar-unknown-exits.3)
(checked-compile-and-assert
()
`(lambda (b)
(let ((a b))
(block nil
(let ((* (list 1)))
(declare (dynamic-extent *))
(if b
(let ((j a))
(let ((* (list 1)))
(declare (dynamic-extent *))
(if b (return 44))
(setf a nil))
(let ((z j)) z))
(eval 2))))))
((33) 44)))
(with-test (:name :substitute-single-use-lvar-unknown-exits.4)
(checked-compile-and-assert
()
`(lambda (a)
(block nil
(flet ((f ()
(let ((p (1+ a)))
(let ((* (list 1)))
(declare (dynamic-extent *))
(if a
(return 45)))
p)))
(let ((* (lambda ()
(return (eval a)))))
(f)))))
((33) 45)))
(with-test (:name :substitute-single-use-lvar-unknown-exits.5)
(checked-compile-and-assert
()
`(lambda (b c)
(block nil
(flet ((f ()
(return (catch 'c (block b b)))))
(return
(block b5
(let ((o c))
(setf c
(catch 'c
(flet ((g ()
(return)))
(f))))
(let ((x o)) x)))))))
((10 20) 10)))
(with-test (:name :substitute-single-use-lvar-unknown-exits.6)
(checked-compile-and-assert
()
`(lambda ()
(block b
(return-from b
(let ((lv3 (random 10))
*)
(boole boole-1 lv3
(the integer
(catch 'ct4
(let ((x (list '*)))
(declare (dynamic-extent x))
(return-from b (eval x))))))))))
(() 1)))
(with-test (:name :lambda-let-inline)
(let ((fun (checked-compile
`(lambda ()
(let ((x (lambda () 1)))
(funcall x))))))
(assert (null (ctu:find-anonymous-callees fun)))
(assert (= (funcall fun) 1))))
(with-test (:name :external-cast-deletion)
(checked-compile-and-assert
()
`(lambda (a c)
(declare (notinline elt logior))
(logior
(if c
(the integer (elt '(10 20) a))
(let ((v1 (loop repeat 3 count t)))
(declare (dynamic-extent v1))
v1))))
((0 t) 10)
((1 nil) 3)))
(with-test (:name :fixnump-instance-ref-immediately-used)
(checked-compile-and-assert
()
`(lambda (a b c)
(let (z)
(and
(typep
(let ((y (let ((s (cons a b)))
(declare (dynamic-extent s))
(cdr s))))
(unwind-protect
(let ((s (list c)))
(declare (dynamic-extent s))
(setf z (car s))))
y)
'fixnum)
z)))
((1 2 'a) 'a)))
(with-test (:name :fixnump-instance-ref-immediately-used.2)
(checked-compile-and-assert
()
`(lambda (a b c)
(let* ((l (cons a b))
(cdr (cdr l)))
(setf (cdr l) c)
(typep cdr 'fixnum)))
((1 2 'a) t)))
(with-test (:name :round-numeric-bound)
(checked-compile-and-assert
()
`(lambda (a c f)
(declare (type (integer -1111868182375 1874303539234) a))
(- (rem (funcall f) (max 23 (* 45092832376540563 a -4469591966)))
(signum c)))
((1874303539234 2 (constantly 123)) 7)))
(with-test (:name :ir2-optimize-jumps-to-nowhere)
(checked-compile-and-assert
()
`(lambda (a)
(declare (type fixnum a))
(if (< a 0 a)
(block a (shiftf a 1))
0))
((0) 0)))
(with-test (:name :double-float-bits-stub)
(checked-compile-and-assert
()
`(lambda (x)
(float-sign 5.0d0 (the double-float x)))
((3d0) 3d0)))
(with-test (:name :typep-word)
(checked-compile-and-assert
()
`(lambda (x)
(typep x 'sb-vm:word))
((1) t)
(((1- (expt 2 sb-vm:n-word-bits))) t)
(((expt 2 sb-vm:n-word-bits)) nil)
((-1) nil)
(('a) nil)
((()) nil)
(((1- most-negative-fixnum)) nil)))
(with-test (:name :fixnum-mod-p-word-descriptor)
(checked-compile-and-assert
()
`(lambda (a)
(declare (type sb-vm:signed-word a))
(typep a '(integer 0 ,(1- most-positive-fixnum))))
(((1- most-positive-fixnum)) t)
((0) t)
((1) t)
((most-positive-fixnum) nil)
(((1+ most-positive-fixnum)) nil)
((most-negative-fixnum) nil)
(((1+ most-negative-fixnum)) nil)
(((1- (expt 2 (1- sb-vm:n-word-bits)))) nil)
((-1) nil)))
(with-test (:name :check-bound-zero-safety-notes)
(checked-compile-and-assert
(:allow-notes nil
:optimize '(:speed 3 :safety 0))
`(lambda (a x y z)
(declare (fixnum x y z)
((simple-array t (*)) a)
(optimize (speed 3) (safety 0)))
(aref a (+ x (- y z))))
((#(1 2 3) 1 0 0) 2)))
(with-test (:name :convert-mv-bind-to-let-multiple-uses)
(checked-compile-and-assert
()
`(lambda (f)
(let* ((a (eval 1))
(b (eval 2)))
(multiple-value-bind (x y) (if f
(values a 1)
(values b 2))
(values x y))))
((t) (values 1 1))
((nil) (values 2 2))))
(with-test (:name :substitute-single-use-lvar-multiple-uses)
(checked-compile-and-assert
()
`(lambda (f)
(let* ((a (eval 1))
(b (eval 2))
(m (if f
(values a)
(values b))))
m))
((t) 1)
((nil) 2)))
(with-test (:name :tn-ref-type-multiple-moves)
(checked-compile-and-assert
()
`(lambda (a c)
(declare (type (integer 546181490258163 937632934000433) c))
(let ((v8 c))
(multiple-value-bind (v9 v6)
(if (/= a v8)
(values 0 10983313414045189807)
(values 0 c))
(declare (ignore v9))
(loop repeat 2
do (eval v6))
v6)))
((0 571816791704489) 10983313414045189807)))
(with-test (:name :substitute-single-use-lvar-cast-chains)
(checked-compile-and-assert
()
`(lambda (f a b)
(labels ((fun (z)
(let ((m z))
;; delays type derivation of FUN as FIXNUM until constraint propagation
;; making sure SUBSTITUTE-SINGLE-USE-LVAR runs first.
(if (typep m 'fixnum)
m
0))))
(declare (inline fun))
(let* ((a (fun a))
(b (fun b)))
(let ((m
(if f
(the fixnum (the integer a))
(the fixnum (the integer b)))))
m))))
((t 1 2) 1)
((nil 1 2) 2)))
(with-test (:name :m-v-bind-multi-use-unused-values.1)
(multiple-value-bind (calls f)
(ctu:ir1-named-calls
'(lambda (z m)
(multiple-value-bind (a b)
(if z
10
(values (sxhash m) m))
(declare (ignore a))
b)))
(assert (eql (funcall f t 33) nil))
(assert (eql (funcall f nil 33) 33))
(assert (not calls))))
(with-test (:name :m-v-bind-multi-use-unused-values.2)
(multiple-value-bind (calls f)
(ctu:ir1-named-calls
'(lambda (z m)
(multiple-value-bind (a b c)
(if z
(values 10)
(values (sxhash m) m))
(declare (ignore a))
(list b c))))
(assert (equal (funcall f t 33) '(nil nil)))
(assert (equal (funcall f nil 33) '(33 nil)))
(assert (not calls))))
(with-test (:name :m-v-bind-multi-use-unused-values.3)
(multiple-value-bind (calls f)
(ctu:ir1-named-calls
'(lambda (z m)
(multiple-value-bind (a b)
(if z
10
(values m (sxhash m)))
(declare (ignore b))
a)))
(assert (eql (funcall f t 33) 10))
(assert (eql (funcall f nil 33) 33))
(assert (not calls))))
(with-test (:name :m-v-bind-multi-use-unused-values.4
:skipped-on :sbcl)
(multiple-value-bind (calls f)
(ctu:ir1-named-calls
'(lambda (z m)
(nth-value 1
(if z
(funcall (the function z))
(values (sxhash m) m)))))
(assert (eql (funcall f (lambda () (values 1 22)) 33) 22))
(assert (eql (funcall f nil 34) 34))
(assert (not calls))))
(with-test (:name :m-v-bind-multi-use-unused-values.5
:skipped-on :sbcl)
(multiple-value-bind (calls f)
(ctu:ir1-named-calls
'(lambda (z m)
(nth-value 1
(if z
(funcall (the function z))
(sxhash m)))))
(assert (eql (funcall f (lambda () (values 1 22)) 33) 22))
(assert (eql (funcall f nil 34) nil))
(assert (not calls))))
(with-test (:name :m-v-bind-multi-use-variable-type-change)
(checked-compile-and-assert
()
'(lambda (p)
(when (position #\a (the (or (simple-string 1) (simple-string 2)) p))
nil))
(("a") nil)
(("ab") nil)))
(with-test (:name :array-element-type-cons.1)
(checked-compile-and-assert
(:allow-notes nil)
'(lambda (vector)
(declare ((or (simple-array (unsigned-byte 32) (2))
(simple-array (unsigned-byte 32) (4))) vector))
(make-array 10 :element-type (array-element-type vector)))
(((make-array 2 :element-type '(unsigned-byte 32)))
'(unsigned-byte 32) :test (lambda (x y)
(equal (array-element-type (car x)) (car y))))))
(with-test (:name :array-element-type-cons.2)
(checked-compile-and-assert
(:allow-notes nil)
'(lambda (vector)
(declare ((and (simple-array (unsigned-byte 32) (2))
(satisfies eval)) vector))
(make-array 10 :element-type (array-element-type vector)))
(((make-array 2 :element-type '(unsigned-byte 32)))
'(unsigned-byte 32) :test (lambda (x y)
(equal (array-element-type (car x)) (car y))))))
(with-test (:name :about-to-modify-symbol-value-relax-fun-type)
(let* ((compiled-lambda (compile nil '(lambda (&rest x) x 'hi)))
(sb-c::*compiler-error-bailout*
(lambda (&optional c) (error c))))
(declare (notinline set))
(set 'sb-c::*compiler-error-bailout* compiled-lambda)))
(with-test (:name :self-evaluating-p-not)
(let ((s (gensym)))
(set s 9)
(unintern s)
(import s 'keyword)
(assert (not (sb-int:self-evaluating-p s)))))
(with-test (:name :lea-modfx-constant-folding)
(checked-compile-and-assert
()
'(lambda (c)
(if (if c
c
(if 444
nil
99))
11
(logand 3
(logxor
(* 5
(if c
0
(ash most-positive-fixnum -2)))
3))))
((t) 11)
((nil) 0)))
(with-test (:name :setup-environment-tn-conflicts)
(checked-compile-and-assert
()
'(lambda (z)
(let ((c 0))
(flet ((bar ()
(let ((m (eval :bad)))
(eval m)
(and m c))))
(declare (notinline bar))
(cond (z
(setf c 10)
(bar))
(44)))))
((t) 10)
((nil) 44)))
(with-test (:name :setup-environment-tn-conflicts.2)
(checked-compile-and-assert
()
'(lambda (z)
(let ((c 0)
(b 0)
(a 0)
(d 0))
(labels ((bar ()
(let ((m (eval :bad)))
(eval m)
(if m
(values a b c d))))
(jam ()
(multiple-value-list (bar))))
(declare (notinline bar
jam))
(cond (z
(setf a 10
c 10
b 10
d 10)
(jam))
(44)))))
((t) '(10 10 10 10) :test #'equal)
((nil) 44)))
(with-test (:name :setup-environment-tn-conflicts.3)
(checked-compile-and-assert
()
'(lambda (b)
(flet ((%f7 ()
(flet ((%f10 ()
(setf b b)))
(declare (dynamic-extent #'%f10))
(funcall (eval #'%f10)))))
(declare (notinline %f7))
(%f7)))
((10) 10)))
(with-test (:name :dead-sets)
(checked-compile-and-assert
()
`(lambda ()
(logtest
((lambda (v &rest args)
(declare (ignore args))
(setf v
((lambda (&rest args) (declare (ignore args)) (error "")) v)))
1)
1))
(() (condition 'simple-error))))
(with-test (:name :inlining-multiple-refs)
(checked-compile
`(lambda (x)
(labels ((%s (y &rest r)
(some
(lambda (r) (apply #'%s (1+ y) r))
(apply #'eql x r))))
(%s 1)))))
(with-test (:name :update-lvar-dependencies-delete-lvar)
(checked-compile-and-assert
()
'(lambda (x y)
(let ((x x))
(block nil
(flet ((proc (thing)
(when thing
(return (eval thing)))))
(declare (inline proc))
(if x
(proc y)
(proc y)))))
t)
((1 2) t)))
(with-test (:name :car-type-on-or-null)
(assert
(equal (sb-kernel:%simple-fun-type
(checked-compile
'(lambda (x)
(declare (type (or null (cons fixnum)) x))
(if x
(car x)
0))))
'(function ((or null (cons fixnum t))) (values fixnum &optional)))))
(with-test (:name :nlx-entry-zero-values)
(checked-compile-and-assert
()
'(lambda (x)
(multiple-value-call (lambda (&optional x) x)
(block nil
(funcall (eval (lambda ()
(return (if x
(values)
10))))))))
((t) nil)
((nil) 10)))
(with-test (:name :find-test-to-eq-with-key)
(checked-compile-and-assert
()
'(lambda (x)
(position (1- (expt x 64)) '((#xFFFFFFFFFFFFFFFF)) :key #'car))
((2) 0)
((1) nil)))
(with-test (:name :maybe-infer-iteration-var-type-on-union)
(checked-compile-and-assert
(:allow-notes nil :optimize '(:speed 3 :compilation-speed 1 :space 1))
`(lambda (a)
(loop repeat (if a 2 0) count 1))
((t) 2)
((nil) 0)))
(with-test (:name :maybe-infer-iteration-var-type-on-union.2)
(checked-compile-and-assert
()
`(lambda (a)
(let ((v4 (the (or (single-float (1.0) (3.0)) (single-float 4.0 5.0)) a)))
(incf v4 1.0)))
((4.0) 5.0)))
(with-test (:name :derive-array-rank-negation)
(checked-compile-and-assert
()
`(lambda (a)
(declare ((not (simple-array * (* *))) a))
(eql (array-rank a) 2))
(((make-array '(2 2) :adjustable t)) t))
(checked-compile-and-assert
()
`(lambda (a)
(declare ((not (simple-array fixnum (* *))) a))
(eql (array-rank a) 2))
(((make-array '(2 2))) t))
(checked-compile-and-assert
()
`(lambda (a)
(declare ((not (and (array * (* *)) (not simple-array))) a))
(eql (array-rank a) 2))
(((make-array '(2 2))) t)))
(with-test (:name :derive-array-rank-negation.2)
(assert
(type-specifiers-equal
(sb-kernel:%simple-fun-type
(checked-compile
'(lambda (x)
(declare ((and simple-array
(not (simple-array * (* *))))
x))
(eql (array-rank x) 2))))
'(function ((and simple-array (not (simple-array * (* *)))))
(values null &optional)))))
(with-test (:name :known-fun-no-fdefn)
(assert (equal (ctu:find-code-constants (checked-compile '(lambda () #'+))
:type 'function)
(list #'+))))
(with-test (:name :double-float-p-weakening)
(checked-compile-and-assert
(:optimize '(:speed 3 :safety 1))
'(lambda (x)
(declare (double-float x))
x)
((0.0) (condition 'type-error))
((1d0) 1d0)))
(declaim (inline inline-fun-arg-mismatch))
(defun inline-fun-arg-mismatch (x)
(declare (optimize (debug 0)))
x)
(with-test (:name :inline-fun-arg-mismatch)
(checked-compile-and-assert
(:allow-warnings '(or sb-int:local-argument-mismatch
#+interpreter simple-warning)) ;; why?
'(lambda ()
(multiple-value-call #'inline-fun-arg-mismatch 1 2))
(() (condition 'program-error))))
(with-test (:name :principal-lvar-ref-use-loop)
(checked-compile-and-assert ()
'(lambda (vector)
(labels ((f (count)
(when (< (aref vector 0) count)
(f count))))))
((1) nil)))
(with-test (:name (:mv-call :more-arg)
:fails-on :mips)
(checked-compile-and-assert
()
'(lambda (&rest rest)
(multiple-value-bind (a b c) (values-list rest)
(declare (ignore c))
(list a b)))
((1 3) '(1 3) :test #'equal)))
(with-test (:name (:mv-call :more-arg-unused)
:fails-on :mips)
(checked-compile-and-assert
()
'(lambda (&rest rest)
(multiple-value-bind (a b) (values-list rest)
(list a b)))
(() '(nil nil) :test #'equal)
((1) '(1 nil) :test #'equal)
((1 3) '(1 3) :test #'equal)))
(with-test (:name :truncate-deriver-on-number-type)
(checked-compile-and-assert
()
'(lambda (i)
(truncate
(labels ((f (&optional (o i))
(declare (ignore o))
(complex 0 0)))
(declare (dynamic-extent (function f)))
(the integer
(multiple-value-call #'f (values))))
3))
((0) (values 0 0))))
(with-test (:name :signum-type-deriver)
(checked-compile-and-assert
()
'(lambda (n)
(typep (signum n) 'complex))
((#C(1 2)) t)
((1d0) nil)
((10) nil)))
(with-test (:name :array-header-p-derivation)
(checked-compile-and-assert
()
'(lambda (q)
(and (typep q '(not simple-array))
(sb-kernel:array-header-p q)))
((10) nil)
(((make-array 10 :adjustable t)) t)))
(with-test (:name :phase-type-derivation)
(checked-compile-and-assert
()
'(lambda (x)
(= (phase (the (integer -1 0) x))
(coerce pi 'single-float)))
((-1) t)
((0) nil)))
(with-test (:name :maybe-negate-check-fun-type)
(checked-compile-and-assert
()
'(lambda (m)
(declare ((or (function (number)) (eql #.#'symbolp)) m))
(the (member 3/4 4/5 1/2 #.#'symbolp) m))
((#'symbolp) #'symbolp)))
(with-test (:name :equal-to-eql)
(let ((f (checked-compile
`(lambda (x y)
(equal (the hash-table x) y)))))
(assert (not (ctu:find-code-constants f :type 'sb-kernel:fdefn))))
(let ((f (checked-compile
`(lambda (x y)
(equalp (the function x) y)))))
(assert (not (ctu:find-code-constants f :type 'sb-kernel:fdefn)))))
(with-test (:name :multiway-branch-duplicate-case)
(let ((f (checked-compile '(lambda (b)
(case b
((1 2) :good)
((3 2) :bad)))
:allow-style-warnings t)))
(assert (eq (funcall f 2) :good))))
(with-test (:name :modular-arith-type-derivers
:fails-on :ppc64)
(let ((f (checked-compile
`(lambda (x)
(declare ((and fixnum
unsigned-byte) x)
(optimize speed))
(rem x 10)))))
(assert (not (ctu:find-code-constants f :type 'bignum)))))
(with-test (:name :deduplicated-fdefns)
(flet ((scan-range (c start end)
(let (dup-fdefns names)
(loop for i from start below end
do (let ((obj (sb-kernel:code-header-ref c i)))
(when (sb-kernel:fdefn-p obj)
(let ((name (sb-kernel:fdefn-name obj)))
(when (member name names)
(push obj dup-fdefns))
(push name names)))))
(assert (not dup-fdefns)))))
(dolist (c (sb-vm:list-allocated-objects :all :type sb-vm:code-header-widetag))
(sb-int:binding* (((start count) (ctu:code-header-fdefn-range c))
(end (+ start count)))
;; Within each subset of FDEFNs there should be no duplicates
;; by name. But there could be an fdefn that is in the union of the two sets.
(scan-range c start end)
(scan-range c end (sb-kernel:code-header-words c))))))
(with-test (:name :map-all-lvar-dests)
(checked-compile-and-assert
()
`(lambda (&key (pred (constantly 44)))
(declare (type function pred))
(funcall pred))
(() 44)))
(with-test (:name (:lvar-fun-name :constant-leaf-not-constant-lvar-p))
(assert (nth-value 1
(checked-compile
`(lambda ()
(funcall
(the (function (t) t)
,(checked-compile '(lambda ())))))
:allow-warnings t
:allow-style-warnings t))))
(with-test (:name (:%logbitp :signed-and-unsigned))
(checked-compile-and-assert
()
`(lambda (p2)
(declare (type (integer ,(expt -2 (1- sb-vm:n-word-bits))
,(1- (expt 2 sb-vm:n-word-bits))) p2))
(logbitp 26 p2))
((3) nil)
(((ash 1 26)) t)))
(with-test (:name :vop-return-constant-boxing)
(checked-compile
`(lambda (x)
(declare (optimize speed))
(setf (aref (the (simple-array double-float (*)) x) 0)
10d0))
:allow-notes nil)
(checked-compile
`(lambda (x)
(declare (optimize speed))
(setf (aref (the (simple-array sb-vm:word (*)) x) 0)
(1- (expt 2 sb-vm:n-word-bits))))
:allow-notes nil)
(checked-compile
`(lambda (x y)
(declare (optimize speed))
(setf (svref y 0)
(setf (aref (the (simple-array double-float (*)) x) 0)
10d0)))
:allow-notes nil)
(checked-compile
`(lambda (f a)
(declare (optimize speed))
(funcall (the function f)
1 2 3 4 5 6 7 8 9 10
(setf (aref (the (simple-array double-float (*)) a) 0)
10d0)))
:allow-notes nil))
(with-test (:name :make-constant-tn-force-boxed)
(checked-compile-and-assert
()
`(lambda (c)
(declare (type character c))
(list 1 1 1 1 1 1 1 1 1 1 1 (the (eql #\() c)))
((#\() '(1 1 1 1 1 1 1 1 1 1 1 #\() :test #'equal)))
(with-test (:name :jump-over-move-coercion
:serial t
:skipped-on :interpreter)
(let ((f (checked-compile
'(lambda (number)
(declare ((or fixnum double-float single-float) number))
(cond ((typep number 'double-float)
number)
((typep number 'single-float)
(coerce number 'double-float))
((typep number 'fixnum)
(coerce number 'double-float)))))))
(ctu:assert-no-consing (funcall f 1d0)))
(let ((f (checked-compile
'(lambda (v number)
(declare ((or fixnum double-float single-float) number))
(setf (svref v 0)
(cond ((typep number 'double-float)
number)
((typep number 'single-float)
(coerce number 'double-float))
((typep number 'fixnum)
(coerce number 'double-float))))))))
(let ((v (vector 0)))
(ctu:assert-no-consing (funcall f v 1d0)))))
(with-test (:name :jump-over-move-coercion-match-type)
(checked-compile-and-assert
()
`(lambda (a b)
(declare (type (or sb-vm:word sb-vm:signed-word) a))
(declare (type (and fixnum unsigned-byte) b))
(lognand (max 0 a) b))
(((expt 2 (1- sb-vm:n-word-bits)) #xFFFFFF) -1)
(((1- (expt 2 (1- sb-vm:n-word-bits))) #xFFFFFF) -16777216)))
#+#.(cl:if (cl:gethash 'sb-c:jump-table sb-c::*backend-template-names*)
'(:and)
'(:or))
(with-test (:name :typecase-to-case-preserves-type)
(let ((f (checked-compile
'(lambda (x)
;; This illustrates another possible improvement-
;; there are not actually 6 different slot indices
;; that we might load. Some of them are the same
(typecase x
(sb-pretty:pprint-dispatch-table (sb-pretty::pp-dispatch-entries x))
(sb-impl::comma (sb-impl::comma-expr x))
(sb-vm:primitive-object (sb-vm:primitive-object-slots x))
(sb-kernel:defstruct-description (sb-kernel::dd-name x))
(sb-kernel:lexenv (sb-c::lexenv-vars x))
(broadcast-stream (broadcast-stream-streams x))
(t :none))))))
;; There should be no #<layout> referenced directly from the code header
;; (which implies that no type-check occurs when accessing a structure instance).
;; There is of course a vector of layouts in there to compare against.
(assert (not (ctu:find-code-constants f :type 'sb-kernel:layout)))
;; The function had better work.
(assert (eq (funcall f 'wat) :none))
(assert (equal (funcall f (make-broadcast-stream *error-output*))
(list *error-output*)))))
(with-test (:name :=-interval-derivation-and-complex)
(checked-compile-and-assert
()
`(lambda (p1)
(declare ((complex (integer -1 -1)) p1))
(= -1 p1))
((#C(-1 -1)) nil)))
(with-test (:name :cmov-move-hoisting)
(checked-compile-and-assert
()
`(lambda (p)
(declare ((or (eql 0.0)
sb-vm:word) p))
(if (> p 51250)
p
1))
((0.0) 1)
((#1=(1- (expt 2 sb-vm:n-word-bits))) #1#))
(checked-compile-and-assert
()
`(lambda (p)
(declare (type (member 4801112936349103672 -9474680540642044437) p))
(max 0 p -1.0))
((4801112936349103672) 4801112936349103672)
((-9474680540642044437) 0)))
(with-test (:name :logior-derive-type-widening-tail-set-types)
(checked-compile-and-assert
()
`(lambda (a b c)
(labels ((q (x y)
(let ((* (lambda () x y)))
(the integer a)))
(p ()
(logior (apply #'q (list a b))
(if b
(return-from p (q b c))
1))))
(if c
0.0
(p))))
((44 nil nil) 45)
((3 2 1) 0.0)
((30 2 nil) 30)))
(with-test (:name :if-eq-optimization-consistency)
(let ((sb-c::*check-consistency* t))
(checked-compile-and-assert
()
`(lambda ()
(eval (and (if (eval 0) (eval 0) (eval 0)) t)))
(() t))))
(with-test (:name :make-array-half-finished-transform)
(checked-compile-and-assert
(:allow-warnings t)
`(lambda ()
(make-array 6 :fill-pointer 33))
(() (condition '(not program-error)))))
(with-test (:name :nested-if+let)
(checked-compile-and-assert
()
`(lambda ()
(let (x)
(when x
(setq x 1))
(let ((y (if x
t
nil)))
(if y
y
(let ((x x))
x)))))
(() nil)))
(with-test (:name :let-var-immediately-used-p-deleted-lambda)
(checked-compile-and-assert
()
`(lambda (c)
(if (and nil
(or
(zerop (count (unwind-protect 1) '(1)))
c))
1
0))
((2) 0)))
(with-test (:name :dce-local-functions)
(checked-compile-and-assert
()
`(lambda ()
(block out
(labels ((mmm (z vars)
(when vars
(mmm z vars))))
(mmm 1 (progn
(dotimes (a 1) (return-from out 10))
(dotimes (b 3) (catch 'b))))
(dotimes (c 3) (catch 'c)))))
(() 10)))
(with-test (:name :dce-more-often)
(checked-compile-and-assert
()
`(lambda (a)
(+ 1
(if t
0
(progn
(tagbody
p
(tagbody
(let ((a (lambda () (go o))))
(declare (special a)))
o)
(when (< a 1)
(go p)))
2))))
((1) 1)
(:return-type (values (integer 1 1) &optional))))
(with-test (:name :dce-more-often.2)
(checked-compile-and-assert
()
`(lambda (b)
(declare (fixnum b))
(- (case 0
(1
(dotimes (i 1 b) (ignore-errors)))
(t 0))))
((3) 0)
(:return-type (values (integer 0 0) &optional))))
(with-test (:name :ir1-optimize-constant-fold-before-giving-up)
(checked-compile-and-assert
()
`(lambda (a)
(+ 2 (- (let ((sum 0))
(declare (type fixnum sum))
(block nil
(tagbody
next
(cond ((>= sum '0)
(go end))
(a
(ceiling 1 (unwind-protect 2))
(incf sum)))
(go next)
end))
sum))))
((1) 2)))
(with-test (:name :position-case-otherwise)
(checked-compile-and-assert
()
`(lambda (x)
(position x '(a otherwise b t nil)))
(('a) 0)
(('otherwise) 1)
((nil) 4)
((t) 3)))
(with-test (:name :unreachable-component-propagate-let-args)
(checked-compile-and-assert
()
`(lambda ()
(let ((p 0))
(flet ((f (&key)
(flet ((g (&optional
(z
(return-from f (+ (dotimes (i 0 0)) p))))
p))))))
p))
(() 0)))
(with-test (:name :dce-through-optional-dispatch)
(checked-compile-and-assert
()
`(lambda (x)
(flet ((z (&optional a)
(declare (ignore a))
123))
(let ((z #'z))
(when x
(unless x
(setf z 10)))
(funcall z))))
((nil) 123)
((t) 123)))
(with-test (:name :values-list+cons)
(assert
(equal (sb-kernel:%simple-fun-type
(checked-compile
`(lambda ()
(values-list (cons 1 nil)))))
'(function () (values (integer 1 1) &optional))))
(assert
(equal (sb-kernel:%simple-fun-type
(checked-compile
`(lambda (x) (values-list (list* x 1 x nil)))))
'(function (t) (values t (integer 1 1) t &optional)))))
(with-test (:name :xeps-and-inlining)
(checked-compile-and-assert
()
`(lambda (args)
(flet ((fun () args))
(declare (inline fun))
(multiple-value-call #'fun (values-list args))
#'fun))))
(with-test (:name :split-let-ctran-kind)
(checked-compile-and-assert
()
`(lambda (a b)
(let ((a-n (null a))
(b-n (null b)))
(cond (b-n 1)
(a-n a)
(t a))))
((nil nil) 1)
((nil t) nil)))
(with-test (:name :dead-component-unused-closure)
(checked-compile-and-assert
()
`(lambda ()
(labels ((%f1 ())
(%f2 (&key)
(flet ((%f3 ()
(unwind-protect 1)
(return-from %f2 (%f1)))))))
(%f1)))
(() nil)))
(with-test (:name :references-to-inline-funs-copied)
(checked-compile-and-assert
()
`(lambda ()
(and (inline-fun-arg-mismatch t)
#'inline-fun-arg-mismatch))
(() #'inline-fun-arg-mismatch)))
(with-test (:name :eliminate-dead-code-before-initial-dfo)
(checked-compile-and-assert
()
`(lambda ()
(block nil
(flet ((f (&key (k1 (catch 'c)))
(max 0
(let ((v9 10))
(return))))))))
(() nil)))
(with-test (:name :%coerce-callable-to-fun-movement)
(checked-compile-and-assert
()
`(lambda (y x)
(let ((x (sb-kernel:%coerce-callable-to-fun x)))
(when y
(funcall x))))
((nil (make-symbol "UNDEF")) (condition 'undefined-function))))
(with-test (:name :jump-table-use-labels)
(checked-compile-and-assert
()
`(lambda (x m)
(case x
((a b c)
(if m
(error ""))
x)
((d e f)
(eval 10)
x)))
(('a nil) 'a)
(('d 30) 'd)))
(with-test (:name :dfo-deleted-lambda-home)
(assert
(nth-value 5 (checked-compile
`(lambda (c)
(flet ((f (&optional (o c))
(lambda (&key)
(+ (restart-bind nil (go missing-tag))
(progv nil nil o)))))))
:allow-failure t))))
(with-test (:name :split-let-unused-vars)
(checked-compile-and-assert
()
`(lambda (x y)
(let ((a
(if x y))
(b)
(c
(if y
x)))
(declare (ignore b))
(if c (if a a c))))
((t t) t)
((t nil) nil)
((nil t) nil)
((nil nil) nil)))
(with-test (:name :sequence-lvar-dimensions-on-arrays)
(checked-compile-and-assert
()
`(lambda (x a)
(count a (make-string x :initial-element a)))
((10 #\a) 10)))
(with-test (:name :length-transform-on-arrays)
(checked-compile-and-assert
()
`(lambda () (length (make-sequence '(string *) 10 :initial-element #\a)))
(() 10)))
(with-test (:name :constant-fold-unknown-types)
(checked-compile-and-assert
(:allow-style-warnings t)
`(lambda ()
(oddp (the (or a b) -1)))))
(with-test (:name :dead-code-no-constant-fold-errors)
(assert
(typep (nth-value 4
(checked-compile
`(lambda (z)
(when (and (eq z 0)
(not (eq z 0)))
(/ 10 0)))))
'(cons sb-ext:code-deletion-note null))))
(with-test (:name :unused-assignment)
(flet ((try (expr &aux (warned 0))
(handler-bind ((style-warning
(lambda (c)
(if (search "assigned but never read" (princ-to-string c))
(incf warned)
(error "That's unexpected")))))
(multiple-value-bind (fun warn error)
(let ((*error-output* (make-broadcast-stream))) (compile nil expr))
(declare (ignore fun))
(assert (and warn (not error) (eql warned 1)))))))
(try '(lambda (x) (let* ((a (+ x 5)) (b a)) (setq b 3) (eval ''z))))
;; Even if the initializer is necessary to call, it's still warning-worthy.
(try '(lambda (x) (let* ((a (+ x 5))
(b (opaque-identity a)))
(setq b 3)
(eval ''z))))
(try '(lambda (x) (let* ((a (+ x 5)) (b a))
(setq b (opaque-identity 3))
(eval ''z)))))
;; This one uses the value of B
(checked-compile '(lambda (x) (let* ((a (+ x 5)) (b a))
(setq b (opaque-identity 3))))))
(with-test (:name :unconvert-tail-calls-terminate-block)
(checked-compile-and-assert
()
`(lambda (x y)
(flet ((f ()
(labels ((a ()
(error "~a" x))
(b ()
(a)))
(if nil
(b)
(if y
(a)
(b))))))
(block nil
(return (f)))))
((t t) (condition 'error))))
(with-test (:name :unconvert-tail-calls-terminate-block.2)
(checked-compile-and-assert
()
`(lambda (x)
(flet ((f ()
(labels ((a ()
(error "foo ~a" x))
(b ()
(let (*)
(a))))
(if nil
(b)
(if nil
(a)
(if x
(a)
(b)))))))
(f)
10))
((t t) (condition 'error))))
(with-test (:name :fixnum-checking-boxing
:skipped-on (not :x86-64))
(checked-compile
`(lambda (x y)
(declare (optimize speed)
(fixnum x y))
(the fixnum (+ x y)))
:allow-notes nil))
(with-test (:name :ltn-analyze-mv-bind)
(checked-compile-and-assert
()
`(lambda ()
(multiple-value-call #'list
10 (apply #'values '(44 33d0))))
(() '(10 44 33d0) :test #'equal)))
(with-test (:name :lp719585)
;; Iteration variables are always "used"
(checked-compile '(lambda () (do (var) (t))))
(checked-compile '(lambda () (do* (var) (t))))
(checked-compile '(lambda () (do-all-symbols (var))))
(checked-compile '(lambda () (do-external-symbols (var))))
(checked-compile '(lambda () (do-symbols (var))))
(checked-compile '(lambda () (dolist (var '(1 2 3))))))
(with-test (:name :key-default-type)
(let ((name (gensym)))
(proclaim `(ftype (function (double-float &key (:y double-float))) ,name))
(checked-compile-and-assert
(:optimize :default)
`(sb-int:named-lambda ,name (x &key (y x))
(values x y))
((1d0 :y nil) (condition 'error)))))
(with-test (:name :deleting-unreachable-floats)
(let ((name (gensym)))
(proclaim `(inline ,name))
(eval `(defun ,name (&key (k (eval 0f0)))
k))
(checked-compile-and-assert
(:allow-notes nil)
`(lambda ()
(,name :k 0f0))
(() 0f0))))
(with-test (:name :no-*-as-type)
(multiple-value-bind (fun errorp warnings)
(checked-compile '(lambda (x) (the * x))
:allow-failure t :allow-warnings t)
(declare (ignore fun))
(assert errorp)
(assert (= (length warnings) 1)))
;; (values t) parses into *wild-type* and has to be allowed
;; even though * which parses into *wild-type* isn't.
(checked-compile '(lambda () (the (values t) t))))
(with-test (:name :hairy-data-vector-set-t-upgrade)
(checked-compile
'(lambda (x) (sb-kernel:hairy-data-vector-set
(the (simple-array symbol) x) 1 'hey))))
(with-test (:name :ir2-convert-reffer-no-lvar)
(checked-compile-and-assert
(:allow-style-warnings t)
`(lambda (a)
(/ (unwind-protect (if a
(values nil (cdr a))
(values 1 0))
a)
1))
((nil) 1)))
(with-test (:name :%eql-integer-fold)
(checked-compile-and-assert
()
`(lambda (d)
(declare (type fixnum d))
(or (find d '(-98 27749116333474161060))
t))
((-98) -98)
((95) t)))
(with-test (:name :svref-with-addend+if-eq-immediate)
(checked-compile-and-assert
()
`(lambda (a d)
(eql (svref a d) -276932090860495638))
((#(1 0) 0) nil)
((#(-276932090860495638) 0) t)))
(with-test (:name :zeroize-stack-tns)
(checked-compile-and-assert
()
`(lambda (a b d e)
(declare (type fixnum a))
(dpb
(ash
(truncate 562949953421316 (max 97 d))
(min 81 (expt (boole boole-and e b) 2)))
(byte 7 5)
(dotimes (i 2 a)
(count i #(61) :test '>=))))
((1 2 3 4) 1985)))
(with-test (:name :logtest-derive-type-nil)
(checked-compile-and-assert
(:allow-warnings t)
`(lambda (c)
(block nil
(evenp (the integer (ignore-errors (return c))))))
((1) 1)))
(with-test (:name :cast-filter-lvar)
(checked-compile-and-assert
(:allow-warnings t)
`(lambda ()
(block nil
(equal
(the integer (tagbody
(let ((* (lambda () (go tag))))
(return))
tag))
(the integer (block nil
(return))))))
(() nil)))
;;; EXPLICIT-CHECK + ETYPECASE should not produce a error message
;;; which reveals whether type-checking on entry to a standard function
;;; was performed this way or that way.
(with-test (:name :etypecase-error-simplify)
(let ((x (nth-value 1 (ignore-errors (logcount (opaque-identity #\a)))))
(y (nth-value 1 (ignore-errors (oddp (opaque-identity #\a))))))
(assert (string= (princ-to-string x) (princ-to-string y)))))
(with-test (:name :set-exclusive-or-inlined)
(checked-compile-and-assert
()
`(lambda (set1 set2)
(declare (inline set-exclusive-or))
(set-exclusive-or set1 set2))))
(declaim (inline inline-deletion-note))
(defun inline-deletion-note (x y)
(if y
10
x))
(with-test (:name :inline-deletion-note)
(checked-compile-and-assert
(:allow-notes nil)
`(lambda (x)
(inline-deletion-note x t))
((t) 10)))
(with-test (:name :inline-type-mismatch)
(checked-compile-and-assert
(:allow-notes nil)
`(lambda (x y)
(car (inline-deletion-note x y)))
(('(a) nil) 'a))
(checked-compile-and-assert
()
`(lambda (x y)
(1+ (position x (the list y))))
((1 '(1)) 1)))
(with-test (:name :lvar-annotation-inline-type-mismatch)
(checked-compile-and-assert
()
`(lambda (x y)
(sb-kernel:the* (float :use-annotations t) (inline-deletion-note x y)))
((1.0 nil) 1.0)))
(with-test (:name :cast-type-preservation)
(assert
(equal (caddr
(sb-kernel:%simple-fun-type
(checked-compile
`(lambda (b)
(declare ((integer 1 1000) b))
(declare (optimize (space 0)))
(gcd 2 b)))))
'(values (integer 1 2) &optional))))
(with-test (:name :lvar-substituting-non-deletable-casts)
(checked-compile-and-assert
()
`(lambda (b)
(the integer
(let (*)
(rem 2
(let ((m
(flet ((f ()
(truncate (the (integer -10 0) b) -4)))
(f))))
(if (> m 1)
1
m)))))
10)
((-10) 10)))
(with-test (:name :convert-mv-bind-to-let-no-casts)
(checked-compile-and-assert
()
`(lambda (a)
(declare (type (integer 7693489 168349189459797431) a))
(max
(floor a
(min -14
(loop for lv3 below 3
sum (mod 77196223293181
(max 75 (mod a (min -57 lv3)))))))))
((8000000) -571429)))
(with-test (:name :values-length-mismatch)
(checked-compile-and-assert
(:allow-style-warnings t :optimize :default)
`(lambda (a)
(declare (values t &optional))
(when a
(values 1 2)))
((nil) nil)
((t) (condition 'type-error))))
(with-test (:name :substitute-single-use-lvar-type-cast-movement)
(checked-compile-and-assert
()
`(lambda (a)
(block nil
(let ((x (multiple-value-prog1 a)))
(when (< a 0)
(return :good))
(if (minusp x)
1
(+ x 1)))))
((-1) :good)
((0) 1)))
(with-test (:name :fold-ash-mod-0)
(checked-compile-and-assert
()
`(lambda ()
(loop for i below 3 sum
(ldb (byte 6 6)
(ash i (mask-field (byte 5 8) i)))))
(() 0)))
(with-test (:name :substitute-single-use-lvar-type-multiple-uses)
(checked-compile-and-assert
()
`(lambda (c)
(let ((z
(ceiling
(truncate 655
(min -7
(if c
-1000
3)))
3)))
z))
((t) 0)
((nil) -31)))
(with-test (:name :division-by-multiplication-type-derivation)
(assert
(type-specifiers-equal
(caddr
(sb-kernel:%simple-fun-type
(checked-compile
`(lambda (c)
(declare (optimize speed))
(ceiling
(truncate 65527
(min -78
(if c
-913097464
5)))
39)))))
'(values (or (integer -21 -21) (integer 0 0)) (integer #+(or arm64 x86-64) -21
#-(or arm64 x86-64) -38 0)
&optional)))
(assert
(type-specifiers-equal
(caddr
(sb-kernel:%simple-fun-type
(checked-compile
`(lambda (c)
(declare (optimize speed))
(ceiling
(truncate 65527
(min 78
(if c
913097464
5)))
39)))))
'(values (or (integer 22 22) (integer 337 337)) (integer -38 -1) &optional))))
(with-test (:name :boundp-ir2-optimizer)
(checked-compile-and-assert
()
`(lambda (v)
(flet ((f (s)
(when (boundp s)
(symbol-value s))))
(f v)
(f v)
v))
((t) t)))
(with-test (:name :nfp-in-unwinding)
(catch 'z
(checked-compile-and-assert
()
`(lambda (x y f)
(declare (double-float x y))
(block nil
(let ((z (+ x y)))
(unwind-protect (funcall f)
(return (+ z 1d0))))))
((4d0 1d0 (lambda () (throw 'z 1))) 6d0))))
(with-test (:name :ir1-optimize-if-same-target-type-derivation)
(checked-compile-and-assert
()
`(lambda (b c)
(declare (notinline equal))
(multiple-value-bind (v7 v2)
(if (equal 0 0)
(values c 0)
(values b 0))
(declare (ignore v2))
(tagbody (progn v7))
b))
((1 2) 1)))
(with-test (:name :delete-let-source-paths)
(checked-compile-and-assert
()
`(lambda (a)
(declare (type (member -3 -54972 3) a))
(values (floor -98740440 a)))
((-3) 32913480)
((3) -32913480)
((-54972) 1796)))
(with-test (:name :unused-debug-tns)
(checked-compile-and-assert
()
`(lambda (d)
(flet ((f (x)
(unwind-protect d
(eval x))))
(dotimes (i 3)
(f (1+ most-positive-fixnum)))))
((3) nil)))
(with-test (:name :exit-becomes-single-value)
(checked-compile-and-assert
()
`(lambda (x z)
(max
(block nil
(flet ((x () (return (floor 1020 z))))
(funcall x #'x))
nil)
10))
(((lambda (x) (funcall x)) 4) 255)))
(with-test (:name :principal-lvar-single-valuify-exit)
(checked-compile-and-assert
()
`(lambda ()
((lambda (a)
(flet ((a ()
(let ((v3 a))
(block nil (truncate (flet ((b ()
(return (block b3 (values 1 v3)))))
(declare (inline b))
(b)))))))
(declare (inline a))
(values (a))))
t))
(() 1)))
(with-test (:name :%coerce-callable-for-call-with-casts
:skipped-on (not :call-symbol))
(multiple-value-bind (calls f)
(ctu:ir1-named-calls
`(lambda (x y)
(apply x 1 2 y)))
(assert (equal (funcall f #'list '(3)) '(1 2 3)))
(assert (equal calls '(x)))))
(with-test (:name :local-fun-type-check-eliminatetion)
(let ((fun (checked-compile '(lambda ()
(flet ((f (x)
(declare (fixnum x))
(1+ x)))
(declare (inline f))
(funcall
(the (function (&optional fixnum)) #'f)
10))))))
(assert (= (sb-kernel:code-n-entries (sb-kernel:fun-code-header fun))
1))))
(with-test (:name :%cleanup-point-transform)
(checked-compile-and-assert
()
`(lambda (a b c)
(declare ((integer -14 49702337) a)
((integer -5376440588342 5921272101558) b)
((integer 3395101368955 8345185767296289) c))
(if (and (< c b) (> a b))
(progv nil
(list 288230376151711735 c)
(restart-bind nil a))
c))
((49702337 5921272101558 8345185767296289) 8345185767296289)))
;;; Test from git rev e47ffa8855d4139f88f5982fe4b82a05c3498ed3.
;;; I have absolutely zero understanding of what this was doing,
;;; but the are bunch of "undefined variable" warnings, so it can't
;;; go at toplevel in a .cload test.
(with-test (:name :bug-226)
(with-scratch-file (lisp "lisp")
(with-open-file (f lisp :direction :output)
(write '(defun bug226 ()
(declare (optimize (speed 0) (safety 3) (debug 3)))
(flet ((safe-format (stream string &rest r)
(unless (ignore-errors (progn
(apply #'format stream string r)
t))
(format stream "~&foo ~S" string))))
(cond
((eq my-result :ERROR)
(cond
((ignore-errors (typep condition result))
(safe-format t "~&bar ~S" result))
(t
(safe-format t "~&baz ~S (~A) ~S" condition condition result)))))))
:stream f :readably t))
(with-scratch-file (fasl "fasl")
(compile-file lisp :output-file fasl))))
;;; I think these tests had to be present in a COMPILE-FILE (as opposed to COMPILE)
;;; to prove that the bug was fixed.
;;; Anway it's no longer going to be allowed to have deliberately bad code in '.cload'
;;; files, because any condition of type warnings or error is considered failure
;;; of the compile step.
(with-test (:name :lp-1276282)
(with-scratch-file (lisp "lisp")
(with-open-file (f lisp :direction :output)
;; from git rev feb31fb6cfc8f89e2d75b5f2cc2ee569ac975033
(format f "(lambda () (the string (+ 1 x)))~%")
;; from git rev fbea35e879891723259dfa55589b498228390bb9
(format f
"(lambda ()
(macrolet ((x (&rest args)
(declare (ignore args))
'a))
(let (a)
(declare (type vector a))
(x #.#'list))))~%"))
(with-scratch-file (fasl "fasl")
(compile-file lisp :output-file fasl))))
(with-test (:name :substitute-single-use-lvar-mv-cast)
(checked-compile-and-assert
()
`(lambda ()
(let ((r (random 10))
(x (list 1)))
(declare (special x)
(dynamic-extent x))
(throw 'c (the (integer 0 10) r))))))
(with-test (:name :list-ir2-convert)
(checked-compile '(lambda ()
(declare (notinline list +))
(list (loop for i below 2 count t)))))
(with-test (:name :bignump-integer-<)
(checked-compile-and-assert
()
`(lambda (a)
(declare (type integer a))
(if (and (typep a 'bignum) (< a 0))
t
nil))
((-1) nil)
(((- (expt 2 300))) t)))
(with-test (:name :cmov-branch)
(checked-compile-and-assert
()
`(lambda (x y)
(assert
(let ((res nil))
(when x (setf res (not res)))
(when y (setf res (not res)))
(not res))))
((1 2) nil)
((nil nil) nil)))
(with-test (:name :constant-type-proclamation)
(ctu:file-compile
`((defconstant +foo+ 4)
(defun bar () +foo+)
(declaim (type integer +foo+)))
:load t)
(assert (eq (funcall 'bar) 4)))
(with-test (:name :if-split-let-blocks)
(checked-compile-and-assert
()
`(lambda (a e)
(labels ((f1 (b)
(map nil
(lambda (n)
(return-from f1 n))
b)
nil)
(f (n)
(let ((x (eval e))
(y (f1 n)))
(if y
y
x))))
(f a)))
((() 1) 1)
(('(2) 1) 2)))
(with-test (:name :duplicate-more-local-tn-overflow)
(let ((vars (loop repeat 200 collect (gensym)))
(args (loop repeat 201 for i from (random 30000)
collect i)))
(assert
(equal
(apply
(compile
()
`(lambda (a ,@vars)
(list a a ,@vars)))
args)
(cons (car args) args)))))
(with-test (:name :aref-single-value-type)
(checked-compile-and-assert
()
`(lambda (x)
(aref (the (values (and (not simple-array) vector)) x) 0))
(((make-array 10 :adjustable t :initial-element 3)) 3)))
(with-test (:name :restoring-tns-after-cleanups)
(checked-compile-and-assert
()
`(lambda ()
(declare (notinline values))
(unwind-protect 1
(let ((a (list 'list)))
(declare (dynamic-extent a))
(unwind-protect 1 (eval a)))
(eval 1)
(eval 2)))
(() 1)))
(defun noflush-symbol-function ()
(declare (optimize safety))
(if (functionp (symbol-function '#:notathing)) 1))
(defun flush-symbol-function ()
(if (functionp (symbol-function '#:notathing)) 1))
(with-test (:name :flush-symbol-function :skipped-on :interpreter)
(assert (ctu:find-code-constants #'noflush-symbol-function))
(assert (not (ctu:find-code-constants #'flush-symbol-function))))
(with-test (:name :symbolp-other-pointer)
(checked-compile-and-assert
()
`(lambda (x)
(declare ((or symbol bit-vector) x))
(the symbol x))
((t) t)))
(with-test (:name :non-nil-symbolp-other-pointer)
(checked-compile-and-assert
()
`(lambda (x)
(declare ((or bignum symbol) x))
(sb-kernel:non-null-symbol-p x))
((t) t)
(((1+ most-positive-fixnum)) nil)
((nil) nil)))
(with-test (:name :list-constant-coalesce)
(checked-compile-and-assert
()
`(lambda ()
(list -13303942049971317088
-6714119381493
-13303942049971317088))
(() '(-13303942049971317088 -6714119381493 -13303942049971317088) :test #'equal)))
(with-test (:name :list-constant-coalesce.2)
(checked-compile-and-assert
()
`(lambda ()
(list -3819610816126750017 -7639221632253500034))
(() '(-3819610816126750017 -7639221632253500034) :test #'equal))
(checked-compile-and-assert
()
`(lambda ()
(list -7639221632253500034 -3819610816126750017))
(() '(-7639221632253500034 -3819610816126750017) :test #'equal)))
(with-test (:name :constraint-loop)
(checked-compile-and-assert
()
`(lambda (b)
(let ((v (elt '(2444 2740 3237 8155 3296 7304 7612 2949) b)))
(progv '(*) (list (ceiling v 40))
*)))
((3) 204)))
(with-test (:name :unused-local-fun-results)
(let ((f `(lambda (x)
(flet ((x ()
(expt x x)))
(x)
(x)
10))))
(assert (not (ctu:ir1-named-calls f)))))
(with-test (:name :ir2opt-tns-without-sc)
(checked-compile-and-assert
()
`(lambda (a)
(boole boole-set (the rational a) a))
((1) -1)))
(with-test (:name set-slot-old-p-optionals)
(checked-compile-and-assert
()
`(lambda (x &key)
(let ((list (list 1)))
(setf (car list) x)
list))
((2) '(2) :test #'equal)))
(with-test (:name :tn-ref-type-ir2opt)
(checked-compile-and-assert
()
`(lambda (p)
(the unsigned-byte
(the (or (array * (1)) real) p)))
((5) 5)))
(with-test (:name :qword-to-dword-cut)
(checked-compile-and-assert
(:allow-warnings t)
`(lambda (a b)
(declare (fixnum b))
(logxor
(lognor (setq a -336272099380508247)
(shiftf b (logorc1 1073741832 a)))
(the (integer -504635362412860905 -99686857090873309) (lognand b 11))))))
(with-test (:name :not-folded-vops)
(assert
(type-specifiers-equal
(caddr
(sb-kernel:%simple-fun-type
(checked-compile
`(lambda ()
(floor
(dpb 42
(byte 15 7)
(block b
(loop for lv below 1 count
(floor
(flet ((%f (f1)
(- (floor f1 f1) (return-from b -9))))
(multiple-value-call #'%f (values (block b3 lv))))
42))))
42)))))
'(values (integer -99734 -99734) (integer 19 19) &optional))))
(with-test (:name :bit-ir2opt)
(checked-compile-and-assert
()
`(lambda (a c)
(declare (fixnum c))
(setf a -14)
(logior
(shiftf a (bit #*01 (max 0 c)))
(max 0 c)))
((1 1) -13)))
(with-test (:name :find-initial-dfo-ignore-let-converted-funs)
(checked-compile-and-assert
()
`(lambda (c)
(tagbody
(flet ((%f7 (f7-3
&optional (f7-4 (go tag5))
(f7-5 ((lambda (&rest args) (go tag5))))
(f7-6 0))
0))
((lambda (v10) (%f7 (go tag5) -63522127 v10)) c))
tag5))
((9) nil)))
(with-test (:name :find-initial-dfo-ignore-assignment-converted-funs)
(checked-compile-and-assert
()
`(lambda ()
(values
(catch 'c 0)
(labels ((%f (&optional (x 0) (y 0)) y))
(case 0
((1) (%f 0))
((2) (%f))))))
(() (values 0 nil))))
(with-test (:name :find-initial-dfo-ignore-assignment-converted-funs.2)
(checked-compile-and-assert
(:allow-style-warnings t)
`(lambda (a)
(let ((v (make-array 1 :initial-element (catch 'ct 42))))
(labels ((f (&optional (x 4) &key (k a)) x))
(if nil (f) (f a)))))
((9) 9)))
(with-test (:name :if-eq-optimizer-nil)
(checked-compile-and-assert
()
`(lambda (x)
(let (b)
(unless (eq x b)
(error ""))
x))
((nil) nil)))
(with-test (:name :assignment-convert-check-same-lvar)
(checked-compile-and-assert
(:allow-style-warnings t)
`(lambda (c)
(flet ((%f9 (f9-1 f9-2 &optional (key1 0))
f9-2))
(multiple-value-prog1 (%f9 701021570480035 c)
(if t
0
(progn
(%f9 1048572 2385880201)
(if t
(%f9 777238289903386671 -15131644893)
0))))))
((10) 10)))
(with-test (:name :range<)
(checked-compile-and-assert
()
`(lambda (l h v)
(declare (fixnum l h))
(if (< l v)
(if (> h v)
:bad
:good)
:bad))
((-1 -1 0) :good)))
(with-test (:name :range<.2)
(checked-compile-and-assert
()
`(lambda (a h)
(declare (fixnum h))
(and (>= a 0)
(not (> h a))))
((1 0) t)
((-1 0) nil)))
(with-test (:name :range<.3)
(checked-compile-and-assert
()
`(lambda (b c)
(and (or (not b) (< 0 c)) (<= c 0)))
((nil -1) t)
((t -1) nil)
((nil 1) nil)))
(with-test (:name :range<.4)
(checked-compile-and-assert
()
`(lambda (f m)
(declare (fixnum f))
(<= (truncate 10 f) m 0))
((-1 0) t)
((1 0) nil)
((-1 10) nil)))
(with-test (:name :range<-equal-bounds)
(checked-compile-and-assert
()
`(lambda (l x h)
(sb-kernel:range< l x h))
((0 0 0) nil)
((0 0.5 0) nil)
((0 -0.5 0) nil)
((0 1/2 0) nil)
((0 -1/2 0) nil))
(checked-compile-and-assert
()
`(lambda (l x h)
(sb-kernel:range<<= l x h))
((0 0 0) nil)
((0 0.5 0) nil)
((0 -0.5 0) nil)
((0 1/2 0) nil)
((0 -1/2 0) nil))
(checked-compile-and-assert
()
`(lambda (l x h)
(sb-kernel:range<=< l x h))
((0 0 0) nil)
((0 0.5 0) nil)
((0 -0.5 0) nil)
((0 1/2 0) nil)
((0 -1/2 0) nil))
(checked-compile-and-assert
()
`(lambda (l x h)
(sb-kernel:range<= l x h))
((0 0 0) t)
((0 0.5 0) nil)
((0 -0.5 0) nil)
((0 1/2 0) nil)
((0 -1/2 0) nil)))
(with-test (:name :move-from-word/fixnum-ir2opt)
(checked-compile-and-assert
()
`(lambda (c)
(declare (type (integer -10 10) c))
(let ((v5 (logior 2305843195621877482 c)))
(values v5
(abs (shiftf v5 (+ v5 1))))))
((-10) (values -2 2))))
(with-test (:name :values-list-type-check
:skipped-on (not (or :x86-64 :arm64)))
(assert (find-if (lambda (line)
(search "BOGUS-ARG-TO-VALUES-LIST-ERROR" line :test #'equal))
(ctu:disassembly-lines
(checked-compile
`(lambda (l)
(let (*)
(values-list l)))))))
(assert (not (find-if (lambda (line)
(search "BOGUS-ARG-TO-VALUES-LIST-ERROR" line :test #'equal))
(ctu:disassembly-lines
(checked-compile
`(lambda (l)
(declare (optimize (safety 0)))
(let (*)
(values-list l)))))))))
(with-test (:name :explicit-value-cell-top-level)
(ctu:file-compile
`((defvar *x*)
(let ((v 0))
(loop repeat 1
do
(setf *x* (lambda () (incf v)))))
(assert (eql (funcall *x*) 1))
(assert (eql (funcall *x*) 2)))
:load t))
(with-test (:name :load-store-two-words-reused-load-tn)
(checked-compile-and-assert
()
`(lambda (x)
(funcall x 1 2 3 4 'a t t))
(('list) '(1 2 3 4 a t t) :test #'equal)))
(with-test (:name :closures-unreachable-components)
(checked-compile-and-assert
()
`(lambda (f)
(catch 'c
(block nil
(labels ((f11 () f)
(b (&key)
(catch 'd
(lambda () #'f11))
(return #'f11)))))))))
(with-test (:name :flushable-nil-funs)
(checked-compile-and-assert
()
`(lambda (a b)
(eq (the (or) (car a))
(the (or) (car b))))))
(with-test (:name :cmov-modifying-input)
(checked-compile-and-assert
()
`(lambda (a b d)
(declare (double-float d))
(values (if (not (> d 10d0))
b
a)
a))
((1 2 1d0) (values 2 1))))
(with-test (:name :ir1-optimize-return-type-widening)
(checked-compile-and-assert
()
`(lambda (a b)
(flet ((f ()
(ceiling a b)))
(values (the integer (f)))))
((1 2) 1)))
(with-test (:name :reuse-coercion)
(multiple-value-bind (fun fail warn style notes)
(checked-compile `(lambda (x d)
(declare (double-float d)
(fixnum x)
(optimize speed))
(cond ((= x 1)
(+ d 1))
((= x 2)
(+ d 2))
((= x 3)
(+ d 3)))))
(declare (ignore fail warn style))
(assert (= (length notes) 1))
(assert (= (funcall fun 1 0d0) 1d0))
(assert (= (funcall fun 2 0d0) 2d0))
(assert (= (funcall fun 3 0d0) 3d0))
(assert (null (funcall fun 4 0d0)))))
(with-test (:name :reorder-keywordp)
(checked-compile-and-assert
()
`(lambda (a)
(cond ((stringp a)
1)
((keywordp a)
2)
((symbolp a)
3)))
(("a") 1)
((:a) 2)
(('m) 3)
((1) nil)))
(with-test (:name :reorder-same-block)
(checked-compile-and-assert
()
`(lambda (a)
(typecase a
(double-float 1)
(fixnum 2)
(bignum 3)
(t 2)))
((1d0) 1)
((1) 2)
(((1+ most-positive-fixnum)) 3)
((t) 2)))
(with-test (:name :unlink-node-in-delete-block)
(checked-compile-and-assert
()
`(lambda (b)
(tagbody
((lambda (v)
(declare (ignore v))
((lambda (a b &rest c)
a b c
(go 7))
(catch 'c 0)
(case b ((-424 -278) b) (t 0))))
((lambda () (go 7))))
7))))
(with-test (:name :multiple-call-unboxed-calls)
(checked-compile-and-assert
()
`(lambda (m j)
(declare (double-float m))
(let (*)
(if j
(funcall j)
(truncate m))))
((1d0 nil) (values 1 0d0))
((4d38 nil) (values 399999999999999990995239293824136118272 0d0)))
(checked-compile-and-assert
()
`(lambda (m j)
(declare (ratio m))
(let (*)
(if j
(funcall j)
(coerce m 'double-float))))
((1/2 nil) 0.5d0))
(checked-compile-and-assert
()
`(lambda (m j)
(declare (double-float m))
(let (*)
(if j
(funcall j)
(scale-float m 2))))
((1d0 nil) 4d0)
((2d0 nil) 8d0)))
(with-test (:name :structure-typep*-deleted-branch)
(checked-compile-and-assert
()
`(lambda (x)
(cond
((typep x 'random-state)
1)
((typep x 'hash-table)
2)
(t x)))
((*random-state*) 1)
(((make-hash-table)) 2)
((423444) 423444)))
(with-test (:name :deleted-call-type)
(checked-compile-and-assert
()
`(lambda (x)
(labels ((foo (x)
x))
(foo 1)
(when x
(unless x
(foo 3)))
(foo 2)))
(:return-type (values (integer 1 2) &optional))))
(with-test (:name :optional-type-propagation)
(checked-compile-and-assert
()
`(lambda ()
(labels ((foo (&optional x)
x))
(foo 1)
(foo 2)))
(:return-type (values (integer 1 2) &optional)))
(checked-compile-and-assert
()
`(lambda ()
(labels ((foo (&key x)
x))
(foo :x 1)
(foo :x 2)))
(:return-type (values (integer 1 2) &optional))))
(with-test (:name :local-function-declaration)
(checked-compile-and-assert
(:optimize :safe)
`(lambda (n)
(declare ((function * fixnum) n))
(typep (funcall n) 'fixnum))
((#'list) (condition 'type-error))))
(declaim (inline member-type-derivation))
(defun member-type-derivation (x)
(member x '(a b c d)))
(with-test (:name :member-type-derivation)
(checked-compile-and-assert
()
`(lambda (n)
(when (member-type-derivation n)
t))
(('a) t)
(('b) t)
(('c) t)
(('d) t)
(('e) nil)))
(with-test (:name :equal-not-null-transform)
(checked-compile-and-assert
()
`(lambda (x y)
(declare (atom x) (list y))
(equalp x y))
((nil nil) t)
((nil '(1)) nil)
((1 nil) nil))
(checked-compile-and-assert
()
`(lambda (x y)
(declare (atom x) (list y))
(equal y x))
((nil nil) t)
((nil '(1)) nil)
((1 nil) nil)))
(with-test (:name :optimize-return-deleted-lambda)
(checked-compile-and-assert
()
`(lambda (x)
(labels ((f1 ()
(case x (:star (f1))))
(f2 (d n)
(case x (:open (f1))))
(f3 (d n)
(case x
(:backquote (f4 d 0))
(:nest
(f3 d n))
(t (f2 d n))))
(f4 (d n)
(case x
(:nest (f3 d n))
(t (f2 d n))))
(f5 (d)
(case x
(:backquote (f4 d 0))
(:nest (f5 d)))))))
((1) nil)))
(with-test (:name :propagate-to-refs-hairy)
(checked-compile-and-assert
()
`(lambda (y)
(declare (fixnum y))
(let ((d (max 1 (the (satisfies eval) y))))
(the fixnum (* d 8))))
((2) 16)))
(with-test (:name :complicated-cons-function-unions)
(checked-compile-and-assert
()
`(lambda (w)
(car (member w '#.(list #'< #'= #'eql #'equalp))))
((#'=) #'=)))
(with-test (:name :tail-calls-terminated-blocks)
(prog* ((f (checked-compile `(lambda (f)
(declare (optimize (debug 1)))
(labels ((f1 (f)
(funcall f)
(f1 f)))
(f1 (f1 f))))))
(x 0))
(assert (funcall f (lambda () (when (= (incf x) 2) (return t)))))))
(with-test (:name :the*-exits)
(checked-compile-and-assert
()
`(lambda (x)
(if x
10
(block nil
(hash-table-test (return)))))
((t) 10)
((nil) nil)))
(with-test (:name :inlining-deleted-go-tag)
(checked-compile-and-assert
()
`(lambda (a)
(tagbody
(labels ((f () (go t)))
(declare (inline f))
(funcall a #'f)
(multiple-value-call #'f (values)))
t)
2)
((#'list) 2)))
(with-test (:name :inling-non-convertible-locals)
(checked-compile-and-assert
()
`(lambda (x)
(labels ((f (&key m)
(values m x)))
(declare (inline f))
(eval (f))
(f x 30)))
((:m) (values 30 :m))
((:allow-other-keys) (values nil :allow-other-keys))))
(with-test (:name :undeleted-exits)
(checked-compile-and-assert
()
`(lambda ()
(tagbody
(flet ((f (a) a (go 5)))
(print (list #'f (loop for i in (f 1)
do (print i)))))
5))
(() nil)))
(with-test (:name :unused-initial-values)
(checked-compile-and-assert
(:allow-notes nil :optimize '(:debug 2 :speed 3 :safety 1))
`(lambda (v)
(declare ((simple-array double-float (*)) v))
(loop for e across v count (> e 0)))
(((make-array 9 :element-type 'double-float :initial-element 1d0)) 9)))
(with-test (:name :consecutive-cast)
(checked-compile-and-assert
()
`(lambda (f)
(the fixnum (the integer (funcall f))))
((#'+) 0))
(checked-compile-and-assert
()
`(lambda (a)
(abs (catch 'c (the (satisfies eval) a))))
((-1) 1))
(checked-compile-and-assert
()
`(lambda (f x)
(the fixnum
(if f
(funcall f)
(the real x))))
((#'* 0) 1)
((nil 2) 2))
(checked-compile-and-assert
(:optimize :safe)
`(lambda (x)
(the vector (the array x)))
((1) (condition 'type-error)))
(checked-compile-and-assert
(:optimize :safe)
`(lambda (x)
(let ((m (the array x)))
(values (the vector m)
m)))
((1) (condition 'type-error)))
(checked-compile-and-assert
(:optimize :safe)
`(lambda (c d m)
(declare (type fixnum c d m))
(the (unsigned-byte 62)
(values
(let ((v (logxor c -7322529 d 9223372036854775805)))
(if (> v 0)
(the unsigned-byte m)
(logior 80827861226 v))))))
((-3462512952 -77 0) (condition 'type-error)))
(checked-compile-and-assert
(:optimize :safe)
`(lambda (x m)
(the fixnum
(if x
(let ((j (the integer m)))
j)
m)))
((nil 'a) (condition 'type-error))
((t 1d0) (condition 'type-error))
((nil 1) 1)
((t 2) 2))
(checked-compile-and-assert
(:optimize :safe)
`(lambda (f x)
(the (values fixnum &optional) (the (values integer &rest t) (funcall f x))))
((#'identity .0) (condition 'type-error))
((#'identity 1) 1)
((#'identity (expt 2 1000)) (condition 'type-error))))
(with-test (:name :pop-values-unused)
(checked-compile-and-assert
()
`(lambda (j l r)
(declare ((function (fixnum &rest t)) j))
(apply j l r))
((#'+ 1 '(2)) 3)))
(with-test (:name :disabling-arg-count-checking)
(checked-compile-and-assert
(:optimize :safe)
`(lambda (x d)
(let ((f (lambda (x y)
(< x y))))
(funcall d f)
(sort x f)))
((nil #'funcall) (condition 'program-error))
((nil #'list) nil))
(checked-compile-and-assert
(:optimize :default)
`(lambda (x d f)
(multiple-value-bind (f key)
(if f
(values f #'car)
(values (lambda (x y)
(< x y))
#'cdr))
(funcall d f)
(sort x f :key key)))
((nil #'funcall nil) (condition 'program-error))
((nil #'list nil) nil)))
(with-test (:name :dont-rebind)
(let ((* :dont-rebind))
(checked-compile-and-assert
()
`(lambda ()
(let* ((x *)
(* x))
x))
(() :dont-rebind))))
(with-test (:name :multiple-uses-type-derivation)
(assert-type
(lambda (x a b)
(funcall (ecase x
(0 #'+)
(1 (lambda (x y) (- x y)))
(2 'logand))
a b))
number)
(assert-type
(lambda (x a b)
(let ((f (ecase x
(0 '+)
(2 'logand))))
(when a
(funcall f a b))))
(or null number)))
(with-test (:name :multiple-uses-to-fdefn)
(checked-compile-and-assert
(:optimize :safe)
`(lambda (x a b)
(let ((fun (ecase x
(0 'a)
(1 'b))))
(when a
(funcall fun a b))))
((0 nil 2) nil)
((0 1 2) (condition 'undefined-function))))
(with-test (:name :undefined-system-fun
:fails-on (and :ppc64 :big-endian))
(checked-compile-and-assert
(:optimize :safe :allow-warnings t)
`(lambda ()
#'nil)
(() (condition 'undefined-function)))
(checked-compile-and-assert
(:optimize :safe :allow-warnings t)
`(lambda ()
#'(setf *standard-output*))
(() (condition 'undefined-function)))
(checked-compile-and-assert
(:optimize :safe :allow-warnings t)
`(lambda ()
(nil))
(() (condition 'undefined-function))))
(with-test (:name :multiple-uses-type-mismatch-from-transforms)
(assert (nth-value 3
(checked-compile
`(lambda (m)
(sb-kernel:the* (fixnum :use-annotations t) (or m (make-array 10))))
:allow-style-warnings t)))
(checked-compile
`(lambda (m s)
(declare (optimize speed))
(sb-kernel:the* (fixnum :use-annotations t) (or m (position 10 (the list s))))))
(assert (nth-value 3
(checked-compile
`(lambda (m)
(the fixnum (or m (make-array 10))))
:allow-style-warnings t)))
(checked-compile
`(lambda (m s)
(declare (optimize speed))
(the fixnum (or m (position 10 (the list s)))))))
(with-test (:name :if-bypass)
(assert-type
(lambda (x)
(declare ((or null vector) x)
(optimize speed))
(if (> (length x) 10)
x
(error "m")))
vector)
(checked-compile-and-assert
()
`(lambda (a)
(evenp (if a 1 0)))
((t) nil)
((nil) t)))
(declaim (inline inline-losing-type))
(defun inline-losing-type (array)
(block nil
(cond ((typep array '(simple-array * (*)))
(return array))
(t (error "x")))))
(with-test (:name :inline-losing-type)
(checked-compile-and-assert
()
`(lambda (array)
(declare (type (or null array) array))
(aref (inline-losing-type array) 0))
((#(1)) 1)))
(with-test (:name :lvar-fun-type-specials)
(checked-compile `(lambda (y) (find t y :test *))))
(with-test (:name :notinline-with-source-transforms)
(checked-compile `(lambda (x y z)
(declare (notinline make-array))
(make-array x y z))))
(with-test (:name :setq-derive-type)
(assert-type
(lambda (x)
(declare (optimize speed))
(values (sb-kernel:%with-array-data-macro (the string x) 0 10)))
simple-string)
(assert-type
(lambda (n m)
(let ((f most-positive-single-float))
(tagbody
:next
(unless (> f n)
(go :end))
(funcall m f)
(setq f (/ f 2.0))
(go :next)
:end)
f))
single-float)
(assert-type
(lambda (l)
(let ((r 0))
(dolist (x l)
(setq r (logior r (truly-the (signed-byte 32) l))))
r))
(signed-byte 32)))
(with-test (:name :if-redundant)
(checked-compile-and-assert
()
`(lambda ()
(let* ((x nil)
(y x))
(setq x t)
(if y x)))
(() nil)))
(with-test (:name :important-result-of-a-constant)
(checked-compile `(lambda ()
(let (x)
(mapcar #'cdr (sort x #'< :key (constantly nil)))))))
(with-test (:name :values-list-stack-push)
(checked-compile-and-assert
()
`(lambda (a b)
(let ((list (if a
'(2 3)
'(1))))
(apply #'list b list)))
((t 1) '(1 2 3) :test #'equal)
((nil 1) '(1 1) :test #'equal)))
(declaim (ftype (function (integer t)) setf-on-ftype))
(with-test (:name :setf-on-ftype)
(checked-compile-and-assert
(:optimize :safe)
`(sb-int:named-lambda setf-on-ftype (x j)
(setf x j)
x)
((nil 1) (condition 'type-error))
((1 nil) nil))
(assert-type
(sb-int:named-lambda setf-on-ftype (x j)
(when j
(incf x))
x)
integer))
(with-test (:name :late-inline-return-from)
(checked-compile `(lambda (r)
((lambda ()
(block nil
(flet ((f ()
(or (funcall r)
(return))))
(declare (inline f))
(when (f)
(f)))))))
:allow-notes 'code-deletion-note))
;;; This trivial function failed to compile due to rev 88d078fe
(with-test (:name :make-list-reduce)
(checked-compile
`(lambda (&key k)
(make-list (reduce #'max (mapcar #'length k))))))
(with-test (:name :cdr-union-types)
(assert-type
(lambda (x)
(cdr (assoc x '((a . 1) (b . 2)))))
(or (eql 1) (eql 2) null))
(assert-type
(lambda (x)
(declare ((member a b) x)
(optimize speed))
(car (assoc x '((a . 1) (b . 3)))))
(member a b)))
(with-test (:name :pop-type)
(assert-type
(lambda (n)
(let ((x '(1 2 3)))
(when n
(setf x (cdr x)))
(car x)))
(or null (integer 1 3)))
(assert-type
(lambda ()
(let ((x '(1 2 3)))
(values (pop x) (pop x))))
(values (integer 1 3) (or null (integer 1 3)) &optional))
(assert-type
(lambda ()
(declare (optimize speed (debug 1)))
(destructuring-bind (a b) '(1 2)
(values a b)))
(values (integer 1 2) (or null (integer 1 2)) &optional))
(assert-type
(lambda (n)
(loop for x in '(a b c)
when (eql n x)
return x))
(member a b c nil))
(assert-type
(lambda (n)
(let ((x '(1 2 (10))))
(dolist (x x)
(when (eql x n)
(return x)))))
(or (integer 1 2) (cons (integer 10 10) null) null))
(assert-type
(lambda (n)
(declare (optimize (debug 2)))
(let ((x '(1 2 3)))
(dolist (x x)
(when (eql x n)
(return x)))))
(or (integer 1 3) null))
(assert-type
(lambda (x)
(do ((cdr '(1 2 3) (cdr cdr)))
((null cdr))
(declare (list cdr))
(let ((car (car cdr)))
(when (eq car x)
(return car)))))
(or (integer 1 3) null))
(assert-type
(lambda (j)
(declare (optimize (debug 2)))
(let ((x nil))
(labels ((f ()
(pop x)))
(when j
(f)
(f)))
x))
null)
(assert-type
(lambda (j)
(block nil
(map nil (lambda (x) (when j (return x))) '(1 2 3))
0))
(integer 0 3))
(assert-type
(lambda (j)
(block nil
(map nil (lambda (x) (when j (return (+ x 1)))) nil)
0))
(eql 0)))
(with-test (:name :test-headers-lowtag-only)
(checked-compile-and-assert
()
`(lambda (a)
(declare ((or hash-table string) a))
(typep a '(or simple-vector string)))
(("") t)
(((make-hash-table)) nil)))
(with-test (:name :&rest-escaping)
(let ((wrapper (lambda (x)
(let ((list (list -1 -2)))
(declare (dynamic-extent list))
(opaque-identity list)
(funcall x)))))
(checked-compile-and-assert
()
`(lambda (control &rest arguments)
(lambda ()
(with-standard-io-syntax
(apply #'format nil control arguments))))
(("~a~a~a" 1 2 3) "123" :test (lambda (f a)
(assert (equal (funcall wrapper (car f)) (car a)))
t)))))
(with-test (:name :&rest-escaping.recursive-reference)
(checked-compile-and-assert
()
`(lambda (control &rest arguments)
(labels ((f ()
(opaque-identity #'g)
(apply #'format nil control arguments))
(g ()
(opaque-identity #'f #'f)))
(declare (dynamic-extent #'g #'f))
(opaque-identity #'g)
(opaque-identity #'f)
(f)))
(("~a~a~a" 1 2 3) "123")))
(with-test (:name :car-eq-if-listp)
(let ((f (compile nil '(lambda (x) (typep x '(cons (eql t)))))))
(assert (eq (funcall f '(t)) t))
(assert (eq (funcall f '(1)) nil))))
(with-test (:name :apply-list-if)
(let ((f (compile nil '(lambda (p) (apply #'list (if p '(a b) '(c d)))))))
(assert (equal (funcall f t) '(a b)))
(assert (equal (funcall f nil) '(c d)))))
(with-test (:name :values-list-if)
(let ((f (compile nil '(lambda (p) (values-list (if p '(a) ()))))))
(multiple-value-call (lambda (x) (assert (eql x 'a))) (funcall f t))
(multiple-value-call (lambda () t) (funcall f nil))))
(with-test (:name :no-notes-list-vs-or-null)
(checked-compile `(lambda (l)
(declare (list l)
(optimize speed))
(coerce l 'vector))
:allow-notes nil))
(with-test (:name :flushable-combination-args-p-lost-annotation)
(checked-compile-and-assert
()
`(lambda (b)
(declare (vector b))
(let ((j))
(find 1 b :key (lambda (x)
(setf j x)))
j))
((#(2)) 2)))
(with-test (:name :constant-fold-variables)
(assert-type
(lambda ()
(declare (optimize (debug 2)))
(let ((x #(a b)))
(aref x 0)))
(eql a)))
(with-test (:name :funcall-externally-checkable-type)
(checked-compile-and-assert
(:optimize :safe)
`(lambda (n m)
(funcall (the (function ((signed-byte 33)) t)
(if m
(lambda (x) x)
(lambda (x) (1+ x))))
n))
(('a t) (condition 'type-error))
(((expt 2 33) nil) (condition 'type-error))
((1 t) 1)
((2 nil) 3))
(checked-compile-and-assert
(:optimize :safe)
`(lambda (n f)
(funcall (the (function ((signed-byte 33)) t)
f)
n))
(('a #'-) (condition 'type-error))
((1 #'-) -1))
(checked-compile-and-assert
(:optimize :safe)
`(lambda (n)
(funcall (the (function ((signed-byte 33)) t)
#'opaque-identity)
n))
(("a") (condition 'type-error))
((2) 2))
(checked-compile-and-assert
(:optimize :safe)
`(lambda (n j)
(funcall (the (function ((signed-byte 33)) (values symbol &optional))
(lambda (x) (when (evenp x)
j)))
n))
((2 'a) 'a)
((2 1) (condition 'type-error))))
(with-test (:name :cast-move-exit)
(checked-compile-and-assert
(:optimize :safe)
`(lambda (m f)
(+ m (catch t (funcall f) 0)))
((1 #'list) 1)
((1 (lambda () (throw t 1))) 2)
((1 (lambda () (throw t t))) (condition 'type-error)))
(checked-compile-and-assert
(:optimize :safe)
`(lambda (f)
(the number (catch t (funcall f) 2)))
((#'list) 2)
(((lambda () (throw t 3))) 3)
(((lambda () (throw t t))) (condition 'type-error)))
(checked-compile-and-assert
(:optimize :safe)
`(lambda (f)
(the number (values (catch t (funcall f) 2))))
((#'list) 2)
(((lambda () (throw t 3))) 3)
(((lambda () (throw t t))) (condition 'type-error)))
(checked-compile-and-assert
(:optimize :safe)
`(lambda (f)
(values (the number (catch t (funcall f) 2))))
((#'list) 2)
(((lambda () (throw t 3))) 3)
(((lambda () (throw t t))) (condition 'type-error))))
(with-test (:name :apply-type-derivation)
(assert-type
(lambda (r)
(apply #'concatenate 'vector r))
simple-vector)
(assert-type
(lambda (a r)
(declare ((array double-float) a))
(apply #'aref a r))
double-float)
(assert-type
(lambda (r)
(apply #'make-array 1 :element-type t r))
(vector t)))
(with-test (:name :foldable-read-only)
(assert-type
(lambda ()
(let ((l (list 1)))
(values (car l)
(car l))))
(values (eql 1) (eql 1) &optional)))
(with-test (:name :>-integer-fixnum)
(checked-compile-and-assert
(:optimize :safe)
`(lambda (v1 m)
(declare (single-float v1)
(integer m))
(if (> (+ v1 4) 0.9)
(>
-7
(+
(if (> v1 7)
#c(4.0 3.0)
2)
m))
(* -0.2 v1)))
((8.0 8) (condition 'type-error))
((-8.0 8) 1.6)))
(with-test (:name :unused-tns-erased-types)
(checked-compile-and-assert
(:optimize :safe :allow-warnings t)
'(lambda (x)
(declare ((integer 10 20) x))
(let ((q (truncate (/ x 0))))
(when (minusp x)
q)))
((10) (condition 'division-by-zero))))
(with-test (:name :constant-fold-call-multiple-uses-casts)
(checked-compile-and-assert
(:optimize :safe
:allow-warnings t)
`(lambda (v)
(if v
(truncate
(if v
#c(1 2)
2)
(if v
9
2))))
((t) (condition 'type-error))
((nil) nil)))
(with-test (:name :cast-externally-checkable-p-vop-ref)
(checked-compile-and-assert
(:optimize :safe)
`(lambda (v3)
(let ((v (the integer v3)))
(values (logand 1 v)
v)))
((t) (condition 'type-error))
((3) (values 1 3)))
(checked-compile-and-assert
(:optimize :safe)
`(lambda (p n)
(declare ((or float (rational 6357799611333445141)) n))
(let ((v (if p
9
(the integer n))))
(values (logand v 9) v)))
((t 1.0) (values 9 9))
((nil 1.0) (condition 'type-error))))
(with-test (:name :un/signed-byte-64-p-move-to-word)
(checked-compile-and-assert
()
`(lambda (x n m)
(declare (integer x n))
(prog ()
sb64
(when (typep x '(signed-byte 64))
(return (logand x 2)))
ub64
(when (typep x '(unsigned-byte 64))
(return (logand x 1)))
(when m
(setf x n
m nil)
(go ub64))))
(((expt 2 64) -1 t) nil)
(((expt 2 64) 3 t) 1)))
(with-test (:name :test-header-lowtag-null)
(checked-compile-and-assert
(:optimize :safe)
`(lambda (x)
(declare ((or bignum null) x))
(logand x 3))
(((+ (expt 2 64) 2)) 2)
((nil) (condition 'type-error))))
(with-test (:name :unwind-protect-mv-bind)
(checked-compile-and-assert
()
`(lambda (m)
(let (n)
(values
(nth-value 1
(unwind-protect
1
(setf n m)))
n)))
((2) (values nil 2)))
(checked-compile-and-assert
()
`(lambda (m)
(nth-value 1
(block nil
(values (unwind-protect t
(return m))))))
((2) nil)))
(with-test (:name :nth-value-the)
(checked-compile-and-assert
(:optimize :safe)
`(lambda (f)
(nth-value 1 (the fixnum (funcall f))))
(((lambda () 1)) nil)
(((lambda () (values 1 2))) 2)
(((lambda () (values t 2))) (condition 'type-error)))
(checked-compile-and-assert
(:optimize :safe)
`(lambda (f)
(values (the (values fixnum fixnum) (funcall f))))
(((lambda () 1)) (condition 'type-error))
(((lambda () (values 1 2))) 1)
(((lambda () (values 2 t))) (condition 'type-error)))
(checked-compile-and-assert
(:optimize :safe)
`(lambda (f)
(values (the (values fixnum &optional fixnum) (funcall f))))
(((lambda () 1)) 1)
(((lambda () (values 1 2))) 1)
(((lambda () (values 2 t))) (condition 'type-error)))
(checked-compile-and-assert
(:optimize :safe)
`(lambda (f)
(values (the real (the (not single-float) (funcall f)))))
(((lambda () 1)) 1)
(((lambda () (values 1 2))) 1)
(((lambda () nil)) (condition 'type-error))
(((lambda () 1.0)) (condition 'type-error)))
(checked-compile-and-assert
(:optimize :safe)
`(lambda (f)
(the (values number number) (funcall f)))
(((lambda () 1)) (condition 'type-error))
(((lambda () (values 1 2))) (values 1 2))
(((lambda () (values nil 2))) (condition 'type-error))
(((lambda () (values 1 nil))) (condition 'type-error)))
(checked-compile-and-assert
(:optimize :safe
:allow-style-warnings t)
`(lambda (f)
(the (values real boolean) (if f (values 1 1))))
((t) (condition 'type-error))
((nil) (condition 'type-error)))
(checked-compile-and-assert
(:optimize :safe :allow-style-warnings t)
`(lambda (f)
(the (values &optional real)
(the (values &optional complex)
(funcall f))))
(((lambda () (values))) (values))
(((lambda () 1)) (condition 'type-error))
(((lambda () #c(1 2))) (condition 'type-error)))
(checked-compile-and-assert
(:optimize :safe :allow-warnings t)
`(lambda ()
(the (values &optional real) nil))
(() (condition 'type-error)))
(checked-compile-and-assert
(:optimize :safe :allow-warnings t)
`(lambda ()
(the (values real (not real)) (floor 1 1)))
(() (condition 'type-error)))
(checked-compile-and-assert
(:optimize :safe :allow-warnings t)
`(lambda ()
(the (values fixnum &optional)
(block nil (floor 2))))
(() (condition 'type-error))))
(with-test (:name :unwrap-predicates-block)
(checked-compile-and-assert
()
`(lambda (v)
(if (block nil (> v 7))
t))
((8) t)
((0) nil)))
(with-test (:name :deleted-node-in-derive-type)
(checked-compile
`(lambda (a)
(declare ((simple-array nil (9)) a))
(setf (aref a 0) 1)
a)))
(with-test (:name :xep-type-derivation)
(assert-type
(lambda (n)
(funcall (if n
(lambda (a) (+ a 2))
(lambda (a) (+ a 1)))
1))
(integer 2 3)))
(with-test (:name :compile-name-correct)
(let ((gensym (gensym)))
(assert (eq (sb-kernel:%fun-name
(symbol-function
(checked-compile
`(lambda (a)
(declare ((simple-array nil (9)) a))
(setf (aref a 0) 1)
a)
:name gensym)))
gensym))))
(declaim (ftype function self-call))
(with-test (:name :compile-self-call-policy.1)
(let ((fun (symbol-function
(checked-compile
`(lambda (a)
(declare (optimize (sb-c::recognize-self-calls 0)))
(if (zerop a)
2
(self-call (1- a))))
:name 'self-call))))
(assert (member 'self-call (ctu:find-named-callees fun)))))
(with-test (:name :compile-self-call-policy.2)
(let ((fun (symbol-function
(checked-compile
`(lambda (a)
(declare (optimize sb-c::recognize-self-calls))
(if (zerop a)
2
(self-call (1- a))))
:name 'self-call))))
(assert (not (member 'self-call (ctu:find-named-callees fun))))))
(with-test (:name :mv-bind-unused-p-multiple-args)
(checked-compile-and-assert
()
`(lambda (x y)
(multiple-value-call #'values t -1 (floor x y)))
((5 3) (values t -1 1 2)))
(checked-compile-and-assert
()
`(lambda (x y)
(multiple-value-call (lambda (a b c d)
(values a b c d)) -1 t (floor x y)))
((3 5) (values -1 t 0 3)))
(checked-compile-and-assert
()
`(lambda (x y)
(multiple-value-call (lambda (a b c d)
(declare (ignore a b))
(values c d)) -1 t (floor x y)))
((3 5) (values 0 3)))
(assert (equal (ctu:ir1-named-calls `(lambda (x y)
(multiple-value-call (lambda (a b c d)
(declare (ignore d))
(values a b c)) -1 t (floor x y))))
'(sb-kernel::floor1))))
(with-test (:name :reusing-inlined-function)
(checked-compile-and-assert
(:optimize '(:safety 1 :debug 3 :space 0))
`(lambda (b)
(values (elt '(1 2) b)
(elt '(3 4) b)))
((0) (values 1 3))
((1) (values 2 4))))
(with-test (:name :annotations-traveling-type-conflicts)
(checked-compile
`(lambda (x)
(let ((g (sb-kernel:the* (symbol :use-annotations t) x)))
(unless (typep g 'symbol)
g)))))
#+sb-devel ;; no sb-c::ir1-attributep
(with-test (:name :unfoldable-functions)
(let (no-folders)
(do-all-symbols (symbol)
(unless (or (equal (package-name (symbol-package symbol))
"SB-BIGNUM")
(eq symbol 'sb-kernel:complex-vector-p))
(loop for name in (list symbol `(setf ,symbol))
do
(let ((info (sb-int:info :function :info name)))
(when (and info
(sb-c::ir1-attributep (sb-c::fun-info-attributes info) sb-c::foldable)
(not (sb-c::fun-info-folder info))
(sb-c::fun-info-templates info))
(unless (fboundp name)
(push name no-folders)))))))
(assert (not no-folders))))
Reference in a new issue View git blame Copy permalink