+
;;;; various compiler tests without side effects
;;;; This software is part of the SBCL system. See the README file for
;;; on the PPC, we got the magic numbers in undefined_tramp wrong for
;;; a while; fixed by CSR 2002-07-18
-(multiple-value-bind (value error)
- (ignore-errors (some-undefined-function))
- (assert (null value))
- (assert (eq (cell-error-name error) 'some-undefined-function)))
+(with-test (:name :undefined-function-error)
+ (multiple-value-bind (value error)
+ (ignore-errors (some-undefined-function))
+ (assert (null value))
+ (assert (eq (cell-error-name error) 'some-undefined-function))))
;;; Non-symbols shouldn't be allowed as VARs in lambda lists. (Where VAR
;;; is a variable name, as in section 3.4.1 of the ANSI spec.)
(declare (type (alien (* (unsigned 8))) a)
(type (unsigned-byte 32) i))
(deref a i))))
- (compiler-note () (error "The code is not optimized.")))
+ (compiler-note (c)
+ (unless (search "%ASH/RIGHT" (first (simple-condition-format-arguments c)))
+ (error "The code is not optimized."))))
(handler-case
(compile nil '(lambda (x)
(error "bad RANDOM event"))))
;;; 0.8.17.28-sma.1 lost derived type information.
-(with-test (:name "0.8.17.28-sma.1" :fails-on :sparc)
+(with-test (:name :0.8.17.28-sma.1 :fails-on :sparc)
(handler-bind ((sb-ext:compiler-note (lambda (c) (error "~A" c))))
(compile nil
'(lambda (x y v)
(compiler-note () (throw :note nil)))
(error "Unreachable code undetected.")))
+(with-test (:name (:compiler :constraint-propagation :float-bounds-3
+ :LP-894498))
+ (catch :note
+ (handler-case
+ (compile nil '(lambda (x)
+ (declare (type (single-float 0.0) x))
+ (when (> x 0.0)
+ (when (zerop x)
+ (error "This is unreachable.")))))
+ (compiler-note () (throw :note nil)))
+ (error "Unreachable code undetected.")))
+
+(with-test (:name (:compiler :constraint-propagation :float-bounds-4
+ :LP-894498))
+ (catch :note
+ (handler-case
+ (compile nil '(lambda (x y)
+ (declare (type (single-float 0.0) x)
+ (type (single-float (0.0)) y))
+ (when (> x y)
+ (when (zerop x)
+ (error "This is unreachable.")))))
+ (compiler-note () (throw :note nil)))
+ (error "Unreachable code undetected.")))
+
(with-test (:name (:compiler :constraint-propagation :var-eql-to-var-1))
(catch :note
(handler-case
(compile nil `(lambda (x)
(declare (character x) (optimize speed))
(,name x))))
- (dolist (name '(char= char/= char< char> char<= char>= char-equal
- char-not-equal char-lessp char-greaterp char-not-greaterp
+ (dolist (name '(char= char/= char< char> char<= char>=
+ char-lessp char-greaterp char-not-greaterp
char-not-lessp))
(setf current name)
(compile nil `(lambda (x y)
(array-in-bounds-p a 5 2))))))
;;; optimizing (EXPT -1 INTEGER)
-(test-util:with-test (:name (expt minus-one integer))
+(with-test (:name (expt -1 integer))
(dolist (x '(-1 -1.0 -1.0d0))
(let ((fun (compile nil `(lambda (x) (expt ,x (the fixnum x))))))
(assert (not (ctu:find-named-callees fun)))
(assert (eql x (funcall fun i)))
(assert (eql (- x) (funcall fun i))))))))
-(with-test (:name (load-time-value :type-derivation))
- (flet ((test (type form value-cell-p)
- (let ((derived (funcall (compile
- nil
- `(lambda ()
- (ctu:compiler-derived-type
- (load-time-value ,form)))))))
- (unless (equal type derived)
- (error "wanted ~S, got ~S" type derived)))))
- (let ((* 10))
- (test '(integer 11 11) '(+ * 1) nil))
- (let ((* "fooo"))
- (test '(integer 4 4) '(length *) t))))
-
(with-test (:name :float-division-using-exact-reciprocal)
(flet ((test (lambda-form arg res &key (check-insts t))
(let* ((fun (compile nil lambda-form))
;; compile-times this is bound to be a bit brittle, but at least
;; here we try to establish a decent baseline.
(flet ((time-it (lambda want)
+ (gc :full t) ; let's keep GCs coming from other code out...
(let* ((start (get-internal-run-time))
- (fun (compile nil lambda))
+ (fun (dotimes (internal-time-resolution-too-low-workaround
+ #+win32 10
+ #-win32 0
+ (compile nil lambda))
+ (compile nil lambda)))
(end (get-internal-run-time))
(got (funcall fun)))
(unless (eql want got)
(with-test (:name :multiple-args-to-function)
(let ((form `(flet ((foo (&optional (x 13)) x))
(funcall (function foo 42))))
- (*evaluator-mode* :interpret))
+ #+sb-eval (*evaluator-mode* :interpret))
+ #+sb-eval
(assert (eq :error
(handler-case (eval form)
(error () :error))))
((integer 0 1) b)
(optimize debug))
(lambda () (< b a)))))
+
+;; Actually tests the assembly of RIP-relative operands to comparison
+;; functions (one of the few x86 instructions that have extra bytes
+;; *after* the mem operand's effective address, resulting in a wrong
+;; offset).
+(with-test (:name :cmpps)
+ (let ((foo (compile nil `(lambda (x)
+ (= #C(2.0 3.0) (the (complex single-float) x))))))
+ (assert (funcall foo #C(2.0 3.0)))
+ (assert (not (funcall foo #C(1.0 2.0))))))
+
+(with-test (:name :cmppd)
+ (let ((foo (compile nil `(lambda (x)
+ (= #C(2d0 3d0) (the (complex double-float) x))))))
+ (assert (funcall foo #C(2d0 3d0)))
+ (assert (not (funcall foo #C(1d0 2d0))))))
+
+(with-test (:name :lvar-externally-checkable-type-nil)
+ ;; Used to signal a BUG during compilation.
+ (let ((fun (compile nil `(lambda (a) (parse-integer "12321321" (the (member :start) a) 1)))))
+ (multiple-value-bind (i p) (funcall fun :start)
+ (assert (= 2321321 i))
+ (assert (= 8 p)))
+ (multiple-value-bind (i e) (ignore-errors (funcall fun :end))
+ (assert (not i))
+ (assert (typep e 'type-error)))))
+
+(with-test (:name :simple-type-error-in-bound-propagation-a)
+ (compile nil `(lambda (i)
+ (declare (unsigned-byte i))
+ (expt 10 (expt 7 (- 2 i))))))
+
+(with-test (:name :simple-type-error-in-bound-propagation-b)
+ (assert (equal `(FUNCTION (UNSIGNED-BYTE)
+ (VALUES (SINGLE-FLOAT -1F0 1F0) &OPTIONAL))
+ (sb-kernel:%simple-fun-type
+ (compile nil `(lambda (i)
+ (declare (unsigned-byte i))
+ (cos (expt 10 (+ 4096 i)))))))))
+
+(with-test (:name :fixed-%more-arg-values)
+ (let ((fun (compile nil `(lambda (&rest rest)
+ (declare (optimize (safety 0)))
+ (apply #'cons rest)))))
+ (assert (equal '(car . cdr) (funcall fun 'car 'cdr)))))
+
+(with-test (:name :bug-826970)
+ (let ((fun (compile nil `(lambda (a b c)
+ (declare (type (member -2 1) b))
+ (array-in-bounds-p a 4 b c)))))
+ (assert (funcall fun (make-array '(5 2 2)) 1 1))))
+
+(with-test (:name :bug-826971)
+ (let* ((foo "foo")
+ (fun (compile nil `(lambda (p1 p2)
+ (schar (the (eql ,foo) p1) p2)))))
+ (assert (eql #\f (funcall fun foo 0)))))
+
+(with-test (:name :bug-738464)
+ (multiple-value-bind (fun warn fail)
+ (compile nil `(lambda ()
+ (flet ((foo () 42))
+ (declare (ftype non-function-type foo))
+ (foo))))
+ (assert (eql 42 (funcall fun)))
+ (assert (and warn (not fail)))))
+
+(with-test (:name :bug-832005)
+ (let ((fun (compile nil `(lambda (x)
+ (declare (type (complex single-float) x))
+ (+ #C(0.0 1.0) x)))))
+ (assert (= (funcall fun #C(1.0 2.0))
+ #C(1.0 3.0)))))
+
+;; A refactoring 1.0.12.18 caused lossy computation of primitive
+;; types for member types.
+(with-test (:name :member-type-primitive-type)
+ (let ((fun (compile nil `(lambda (p1 p2 p3)
+ (if p1
+ (the (member #c(1.2d0 1d0)) p2)
+ (the (eql #c(1.0 1.0)) p3))))))
+ (assert (eql (funcall fun 1 #c(1.2d0 1d0) #c(1.0 1.0))
+ #c(1.2d0 1.0d0)))))
+
+;; Fall-through jump elimination made control flow fall through to trampolines.
+;; Reported by Eric Marsden on sbcl-devel@ 2011.10.26, with a test case
+;; reproduced below (triggered a corruption warning and a memory fault).
+(with-test (:name :bug-883500)
+ (funcall (compile nil `(lambda (a)
+ (declare (type (integer -50 50) a))
+ (declare (optimize (speed 0)))
+ (mod (mod a (min -5 a)) 5)))
+ 1))
+
+;; Test for literals too large for the ISA (e.g. (SIGNED-BYTE 13) on SPARC).
+#+sb-unicode
+(with-test (:name :bug-883519)
+ (compile nil `(lambda (x)
+ (declare (type character x))
+ (eql x #\U0010FFFF))))
+
+;; Wide fixnum platforms had buggy address computation in atomic-incf/aref
+(with-test (:name :bug-887220)
+ (let ((incfer (compile
+ nil
+ `(lambda (vector index)
+ (declare (type (simple-array sb-ext:word (4))
+ vector)
+ (type (mod 4) index))
+ (sb-ext:atomic-incf (aref vector index) 1)
+ vector))))
+ (assert (equalp (funcall incfer
+ (make-array 4 :element-type 'sb-ext:word
+ :initial-element 0)
+ 1)
+ #(0 1 0 0)))))
+
+(with-test (:name :catch-interferes-with-debug-names)
+ (let ((fun (funcall
+ (compile nil
+ `(lambda ()
+ (catch 'out
+ (flet ((foo ()
+ (throw 'out (lambda () t))))
+ (foo))))))))
+ (assert (equal '(lambda () :in foo) (sb-kernel:%fun-name fun)))))
+
+(with-test (:name :interval-div-signed-zero)
+ (let ((fun (compile nil
+ `(Lambda (a)
+ (declare (type (member 0 -272413371076) a))
+ (ffloor (the number a) -63243.127451934015d0)))))
+ (multiple-value-bind (q r) (funcall fun 0)
+ (assert (eql -0d0 q))
+ (assert (eql 0d0 r)))))
+
+(with-test (:name :non-constant-keyword-typecheck)
+ (let ((fun (compile nil
+ `(lambda (p1 p3 p4)
+ (declare (type keyword p3))
+ (tree-equal p1 (cons 1 2) (the (member :test) p3) p4)))))
+ (assert (funcall fun (cons 1.0 2.0) :test '=))))
+
+(with-test (:name :truncate-wild-values)
+ (multiple-value-bind (q r)
+ (handler-bind ((warning #'error))
+ (let ((sb-c::*check-consistency* t))
+ (funcall (compile nil
+ `(lambda (a)
+ (declare (type (member 1d0 2d0) a))
+ (block return-value-tag
+ (funcall
+ (the function
+ (catch 'debug-catch-tag
+ (return-from return-value-tag
+ (progn (truncate a)))))))))
+ 2d0)))
+ (assert (eql 2 q))
+ (assert (eql 0d0 r))))
+
+(with-test (:name :boxed-fp-constant-for-full-call)
+ (let ((fun (compile nil
+ `(lambda (x)
+ (declare (double-float x))
+ (unknown-fun 1.0d0 (+ 1.0d0 x))))))
+ (assert (equal '(1.0d0) (ctu:find-code-constants fun :type 'double-float)))))
+
+(with-test (:name :only-one-boxed-constant-for-multiple-uses)
+ (let* ((big (1+ most-positive-fixnum))
+ (fun (compile nil
+ `(lambda (x)
+ (unknown-fun ,big (+ ,big x))))))
+ (assert (= 1 (length (ctu:find-code-constants fun :type `(eql ,big)))))))
+
+(with-test (:name :fixnum+float-coerces-fixnum
+ :skipped-on :x86)
+ (let ((fun (compile nil
+ `(lambda (x y)
+ (declare (fixnum x)
+ (single-float y))
+ (+ x y)))))
+ (assert (not (ctu:find-named-callees fun)))
+ (assert (not (search "GENERIC"
+ (with-output-to-string (s)
+ (disassemble fun :stream s)))))))
+
+(with-test (:name :bug-803508)
+ (compile nil `(lambda ()
+ (print
+ (lambda (bar)
+ (declare (dynamic-extent bar))
+ (foo bar))))))
+
+(with-test (:name :bug-803508-b)
+ (compile nil `(lambda ()
+ (list
+ (lambda (bar)
+ (declare (dynamic-extent bar))
+ (foo bar))))))
+
+(with-test (:name :bug-803508-c)
+ (compile nil `(lambda ()
+ (list
+ (lambda (bar &optional quux)
+ (declare (dynamic-extent bar quux))
+ (foo bar quux))))))
+
+(with-test (:name :cprop-with-constant-but-assigned-to-closure-variable)
+ (compile nil `(lambda (b c d)
+ (declare (type (integer -20545789 207590862) c))
+ (declare (type (integer -1 -1) d))
+ (let ((i (unwind-protect 32 (shiftf d -1))))
+ (or (if (= d c) 2 (= 3 b)) 4)))))
+
+(with-test (:name :bug-913232)
+ (compile nil `(lambda (x)
+ (declare (optimize speed)
+ (type (or (and (or (integer -100 -50)
+ (integer 100 200)) (satisfies foo))
+ (and (or (integer 0 10) (integer 20 30)) a)) x))
+ x))
+ (compile nil `(lambda (x)
+ (declare (optimize speed)
+ (type (and fixnum a) x))
+ x)))
+
+(with-test (:name :bug-959687)
+ (multiple-value-bind (fun warn fail)
+ (compile nil `(lambda (x)
+ (case x
+ (t
+ :its-a-t)
+ (otherwise
+ :somethign-else))))
+ (assert (and warn fail))
+ (assert (not (ignore-errors (funcall fun t)))))
+ (multiple-value-bind (fun warn fail)
+ (compile nil `(lambda (x)
+ (case x
+ (otherwise
+ :its-an-otherwise)
+ (t
+ :somethign-else))))
+ (assert (and warn fail))
+ (assert (not (ignore-errors (funcall fun t))))))
+
+(with-test (:name :bug-924276)
+ (assert (eq :style-warning
+ (handler-case
+ (compile nil `(lambda (a)
+ (cons a (symbol-macrolet ((b 1))
+ (declare (ignorable a))
+ :c))))
+ (style-warning ()
+ :style-warning)))))
+
+(with-test (:name :bug-974406)
+ (let ((fun32 (compile nil `(lambda (x)
+ (declare (optimize speed (safety 0)))
+ (declare (type (integer 53 86) x))
+ (logand (+ x 1032791128) 11007078467))))
+ (fun64 (compile nil `(lambda (x)
+ (declare (optimize speed (safety 0)))
+ (declare (type (integer 53 86) x))
+ (logand (+ x 1152921504606846975)
+ 38046409652025950207)))))
+ (assert (= (funcall fun32 61) 268574721))
+ (assert (= (funcall fun64 61) 60)))
+ (let (result)
+ (do ((width 5 (1+ width)))
+ ((= width 130))
+ (dotimes (extra 4)
+ (let ((fun (compile nil `(lambda (x)
+ (declare (optimize speed (safety 0)))
+ (declare (type (integer 1 16) x))
+ (logand
+ (+ x ,(1- (ash 1 width)))
+ ,(logior (ash 1 (+ width 1 extra))
+ (1- (ash 1 width))))))))
+ (unless (= (funcall fun 16) (logand 15 (1- (ash 1 width))))
+ (push (cons width extra) result)))))
+ (assert (null result))))
+
+;; On x86-64 MOVE-IMMEDIATE of fixnum values into memory either directly
+;; uses a MOV into memory or goes through a temporary register if the
+;; value is larger than a certain number of bits. Check that it respects
+;; the limits of immediate arguments to the MOV instruction (if not, the
+;; assembler will fail an assertion) and doesn't have sign-extension
+;; problems. (The test passes fixnum constants through the MOVE VOP
+;; which calls MOVE-IMMEDIATE.)
+(with-test (:name :constant-fixnum-move)
+ (let ((f (compile nil `(lambda (g)
+ (funcall g
+ ;; The first three args are
+ ;; uninteresting as they are
+ ;; passed in registers.
+ 1 2 3
+ ,@(loop for i from 27 to 32
+ collect (expt 2 i)))))))
+ (assert (every #'plusp (funcall f #'list)))))
+
+(with-test (:name (:malformed-ignore :lp-1000239))
+ (raises-error?
+ (eval '(lambda () (declare (ignore (function . a)))))
+ sb-int:compiled-program-error)
+ (raises-error?
+ (eval '(lambda () (declare (ignore (function a b)))))
+ sb-int:compiled-program-error)
+ (raises-error?
+ (eval '(lambda () (declare (ignore (function)))))
+ sb-int:compiled-program-error)
+ (raises-error?
+ (eval '(lambda () (declare (ignore (a)))))
+ sb-int:compiled-program-error)
+ (raises-error?
+ (eval '(lambda () (declare (ignorable (a b)))))
+ sb-int:compiled-program-error))
+
+(with-test (:name :malformed-type-declaraions)
+ (compile nil '(lambda (a) (declare (type (integer 1 2 . 3) a)))))
+
+(with-test (:name :compiled-program-error-escaped-source)
+ (assert
+ (handler-case
+ (funcall (compile nil `(lambda () (lambda ("foo")))))
+ (sb-int:compiled-program-error (e)
+ (let ((source (read-from-string (sb-kernel::program-error-source e))))
+ (equal source '#'(lambda ("foo"))))))))
+
+(with-test (:name :escape-analysis-for-nlxs)
+ (flet ((test (check lambda &rest args)
+ (let* ((cell-note nil)
+ (fun (handler-bind ((compiler-note
+ (lambda (note)
+ (when (search
+ "Allocating a value-cell at runtime for"
+ (princ-to-string note))
+ (setf cell-note t)))))
+ (compile nil lambda))))
+ (assert (eql check cell-note))
+ (if check
+ (assert
+ (eq :ok
+ (handler-case
+ (dolist (arg args nil)
+ (setf fun (funcall fun arg)))
+ (sb-int:simple-control-error (e)
+ (when (equal
+ (simple-condition-format-control e)
+ "attempt to RETURN-FROM a block or GO to a tag that no longer exists")
+ :ok)))))
+ (ctu:assert-no-consing (apply fun args))))))
+ (test nil `(lambda (x)
+ (declare (optimize speed))
+ (block out
+ (flet ((ex () (return-from out 'out!)))
+ (typecase x
+ (cons (or (car x) (ex)))
+ (t (ex)))))) :foo)
+ (test t `(lambda (x)
+ (declare (optimize speed))
+ (funcall
+ (block nasty
+ (flet ((oops () (return-from nasty t)))
+ #'oops)))) t)
+ (test t `(lambda (r)
+ (declare (optimize speed))
+ (block out
+ (flet ((ex () (return-from out r)))
+ (lambda (x)
+ (typecase x
+ (cons (or (car x) (ex)))
+ (t (ex))))))) t t)
+ (test t `(lambda (x)
+ (declare (optimize speed))
+ (flet ((eh (x)
+ (flet ((meh () (return-from eh 'meh)))
+ (lambda ()
+ (typecase x
+ (cons (or (car x) (meh)))
+ (t (meh)))))))
+ (funcall (eh x)))) t t)))
+
+(with-test (:name (:bug-1050768 :symptom))
+ ;; Used to signal an error.
+ (compile nil
+ `(lambda (string position)
+ (char string position)
+ (array-in-bounds-p string (1+ position)))))
+
+(with-test (:name (:bug-1050768 :cause))
+ (let ((types `((string string)
+ ((or (simple-array character 24) (vector t 24))
+ (or (simple-array character 24) (vector t))))))
+ (dolist (pair types)
+ (destructuring-bind (orig conservative) pair
+ (assert sb-c::(type= (specifier-type cl-user::conservative)
+ (conservative-type (specifier-type cl-user::orig))))))))
+
+(with-test (:name (:smodular64 :wrong-width))
+ (let ((fun (compile nil
+ '(lambda (x)
+ (declare (type (signed-byte 64) x))
+ (sb-c::mask-signed-field 64 (- x 7033717698976965573))))))
+ (assert (= (funcall fun 10038) -7033717698976955535))))
+
+(with-test (:name (:smodular32 :wrong-width))
+ (let ((fun (compile nil '(lambda (x)
+ (declare (type (signed-byte 31) x))
+ (sb-c::mask-signed-field 31 (- x 1055131947))))))
+ (assert (= (funcall fun 10038) -1055121909))))
+
+(with-test (:name :first-open-coded)
+ (let ((fun (compile nil `(lambda (x) (first x)))))
+ (assert (not (ctu:find-named-callees fun)))))
+
+(with-test (:name :second-open-coded)
+ (let ((fun (compile nil `(lambda (x) (second x)))))
+ (assert (not (ctu:find-named-callees fun)))))
+
+(with-test (:name :svref-of-symbol-macro)
+ (compile nil `(lambda (x)
+ (symbol-macrolet ((sv x))
+ (values (svref sv 0) (setf (svref sv 0) 99))))))
+
+;; The compiler used to update the receiving LVAR's type too
+;; aggressively when converting a large constant to a smaller
+;; (potentially signed) one, causing other branches to be
+;; inferred as dead.
+(with-test (:name :modular-cut-constant-to-width)
+ (let ((test (compile nil
+ `(lambda (x)
+ (logand 254
+ (case x
+ ((3) x)
+ ((2 2 0 -2 -1 2) 9223372036854775803)
+ (t 358458651)))))))
+ (assert (= (funcall test -10470605025) 26))))
+
+(with-test (:name :append-type-derivation)
+ (let ((test-cases
+ '((lambda () (append 10)) (integer 10 10)
+ (lambda () (append nil 10)) (integer 10 10)
+ (lambda (x) (append x 10)) (or (integer 10 10) cons)
+ (lambda (x) (append x (cons 1 2))) cons
+ (lambda (x y) (append x (cons 1 2) y)) cons
+ (lambda (x y) (nconc x (the list y) x)) t
+ (lambda (x y) (nconc (the atom x) y)) t
+ (lambda (x y) (nconc (the (or null (eql 10)) x) y)) t
+ (lambda (x y) (nconc (the (or cons vector) x) y)) cons
+ (lambda (x y) (nconc (the sequence x) y)) t
+ (lambda (x y) (print (length y)) (append x y)) sequence
+ (lambda (x y) (print (length y)) (append x y)) sequence
+ (lambda (x y) (append (the (member (a) (b)) x) y)) cons
+ (lambda (x y) (append (the (member (a) (b) c) x) y)) cons
+ (lambda (x y) (append (the (member (a) (b) nil) x) y)) t)))
+ (loop for (function result-type) on test-cases by #'cddr
+ do (assert (sb-kernel:type= (sb-kernel:specifier-type
+ (car (cdaddr (sb-kernel:%simple-fun-type
+ (compile nil function)))))
+ (sb-kernel:specifier-type result-type))))))
+
+(with-test (:name :bug-504121)
+ (compile nil `(lambda (s)
+ (let ((p1 #'upper-case-p))
+ (funcall
+ (lambda (g)
+ (funcall p1 g))))
+ (let ((p2 #'(lambda (char) (upper-case-p char))))
+ (funcall p2 s)))))
+
+(with-test (:name (:bug-504121 :optional-missing))
+ (compile nil `(lambda (s)
+ (let ((p1 #'upper-case-p))
+ (funcall
+ (lambda (g &optional x)
+ (funcall p1 g))))
+ (let ((p2 #'(lambda (char) (upper-case-p char))))
+ (funcall p2 s)))))
+
+(with-test (:name (:bug-504121 :optional-superfluous))
+ (compile nil `(lambda (s)
+ (let ((p1 #'upper-case-p))
+ (funcall
+ (lambda (g &optional x)
+ (funcall p1 g))
+ #\1 2 3))
+ (let ((p2 #'(lambda (char) (upper-case-p char))))
+ (funcall p2 s)))))
+
+(with-test (:name (:bug-504121 :key-odd))
+ (compile nil `(lambda (s)
+ (let ((p1 #'upper-case-p))
+ (funcall
+ (lambda (g &key x)
+ (funcall p1 g))
+ #\1 :x))
+ (let ((p2 #'(lambda (char) (upper-case-p char))))
+ (funcall p2 s)))))
+
+(with-test (:name (:bug-504121 :key-unknown))
+ (compile nil `(lambda (s)
+ (let ((p1 #'upper-case-p))
+ (funcall
+ (lambda (g &key x)
+ (funcall p1 g))
+ #\1 :y 2))
+ (let ((p2 #'(lambda (char) (upper-case-p char))))
+ (funcall p2 s)))))
+
+(with-test (:name :bug-1181684)
+ (compile nil `(lambda ()
+ (let ((hash #xD13CCD13))
+ (setf hash (logand most-positive-word
+ (ash hash 5)))))))
+
+(with-test (:name (:local-&optional-recursive-inline :bug-1180992))
+ (compile nil
+ `(lambda ()
+ (labels ((called (&optional a))
+ (recursed (&optional b)
+ (called)
+ (recursed)))
+ (declare (inline recursed called))
+ (recursed)))))
+
+(with-test (:name :constant-fold-logtest)
+ (assert (equal (sb-kernel:%simple-fun-type
+ (compile nil `(lambda (x)
+ (declare (type (mod 1024) x)
+ (optimize speed))
+ (logtest x 2048))))
+ '(function ((unsigned-byte 10)) (values null &optional)))))
+
+;; type mismatches on LVARs with multiple potential sources used to
+;; be reported as mismatches with the value NIL. Make sure we get
+;; a warning, but that it doesn't complain about a constant NIL ...
+;; of type FIXNUM.
+(with-test (:name (:multiple-use-lvar-interpreted-as-NIL :cast))
+ (block nil
+ (handler-bind ((sb-int:type-warning
+ (lambda (c)
+ (assert
+ (not (search "Constant "
+ (simple-condition-format-control
+ c))))
+ (return))))
+ (compile nil `(lambda (x y z)
+ (declare (type fixnum y z))
+ (aref (if x y z) 0))))
+ (error "Where's my warning?")))
+
+(with-test (:name (:multiple-use-lvar-interpreted-as-NIL catch))
+ (block nil
+ (handler-bind ((style-warning
+ (lambda (c)
+ (assert
+ (not (position
+ nil
+ (simple-condition-format-arguments c))))
+ (return))))
+ (compile nil `(lambda (x y z f)
+ (declare (type fixnum y z))
+ (catch (if x y z) (funcall f)))))
+ (error "Where's my style-warning?")))
+
+;; Smoke test for rightward shifts
+(with-test (:name (:ash/right-signed))
+ (let* ((f (compile nil `(lambda (x y)
+ (declare (type (mod ,(* 2 sb-vm:n-word-bits)) y)
+ (type sb-vm:signed-word x)
+ (optimize speed))
+ (ash x (- y)))))
+ (max (ash most-positive-word -1))
+ (min (- -1 max)))
+ (flet ((test (x y)
+ (assert (= (ash x (- y))
+ (funcall f x y)))))
+ (dotimes (x 32)
+ (dotimes (y (* 2 sb-vm:n-word-bits))
+ (test x y)
+ (test (- x) y)
+ (test (- max x) y)
+ (test (+ min x) y))))))
+
+(with-test (:name (:ash/right-unsigned))
+ (let ((f (compile nil `(lambda (x y)
+ (declare (type (mod ,(* 2 sb-vm:n-word-bits)) y)
+ (type word x)
+ (optimize speed))
+ (ash x (- y)))))
+ (max most-positive-word))
+ (flet ((test (x y)
+ (assert (= (ash x (- y))
+ (funcall f x y)))))
+ (dotimes (x 32)
+ (dotimes (y (* 2 sb-vm:n-word-bits))
+ (test x y)
+ (test (- max x) y))))))
+
+(with-test (:name (:ash/right-fixnum))
+ (let ((f (compile nil `(lambda (x y)
+ (declare (type (mod ,(* 2 sb-vm:n-word-bits)) y)
+ (type fixnum x)
+ (optimize speed))
+ (ash x (- y))))))
+ (flet ((test (x y)
+ (assert (= (ash x (- y))
+ (funcall f x y)))))
+ (dotimes (x 32)
+ (dotimes (y (* 2 sb-vm:n-word-bits))
+ (test x y)
+ (test (- x) y)
+ (test (- most-positive-fixnum x) y)
+ (test (+ most-negative-fixnum x) y))))))
+
+;; expected failure
+(with-test (:name :fold-index-addressing-positive-offset)
+ (let ((f (compile nil `(lambda (i)
+ (if (typep i '(integer -31 31))
+ (aref #. (make-array 63) (+ i 31))
+ (error "foo"))))))
+ (funcall f -31)))
+
+;; 5d3a728 broke something like this in CL-PPCRE
+(with-test (:name :fold-index-addressing-potentially-negative-index)
+ (compile nil `(lambda (index vector)
+ (declare (optimize speed (safety 0))
+ ((simple-array character (*)) vector)
+ ((unsigned-byte 24) index))
+ (aref vector (1+ (mod index (1- (length vector))))))))
+
+(with-test (:name :constant-fold-ash/right-fixnum)
+ (compile nil `(lambda (a b)
+ (declare (type fixnum a)
+ (type (integer * -84) b))
+ (ash a b))))
+
+(with-test (:name :constant-fold-ash/right-word)
+ (compile nil `(lambda (a b)
+ (declare (type word a)
+ (type (integer * -84) b))
+ (ash a b))))
+
+(with-test (:name :nconc-derive-type)
+ (let ((function (compile nil `(lambda (x y)
+ (declare (type (or cons fixnum) x))
+ (nconc x y)))))
+ (assert (equal (sb-kernel:%simple-fun-type function)
+ '(function ((or cons fixnum) t) (values cons &optional))))))
+
+;; make sure that all data-vector-ref-with-offset VOPs are either
+;; specialised on a 0 offset or accept signed indices
+(with-test (:name :data-vector-ref-with-offset-signed-index)
+ (let ((dvr (find-symbol "DATA-VECTOR-REF-WITH-OFFSET" "SB-KERNEL")))
+ (when dvr
+ (assert
+ (null
+ (loop for info in (sb-c::fun-info-templates
+ (sb-c::fun-info-or-lose dvr))
+ for (nil second-arg third-arg) = (sb-c::vop-info-arg-types info)
+ unless (or (typep second-arg '(cons (eql :constant)))
+ (find '(integer 0 0) third-arg :test 'equal)
+ (equal second-arg
+ `(:or ,(sb-c::primitive-type-or-lose
+ 'sb-vm::positive-fixnum)
+ ,(sb-c::primitive-type-or-lose
+ 'fixnum))))
+ collect info))))))
+
+(with-test (:name :data-vector-set-with-offset-signed-index)
+ (let ((dvr (find-symbol "DATA-VECTOR-SET-WITH-OFFSET" "SB-KERNEL")))
+ (when dvr
+ (assert
+ (null
+ (loop for info in (sb-c::fun-info-templates
+ (sb-c::fun-info-or-lose dvr))
+ for (nil second-arg third-arg) = (sb-c::vop-info-arg-types info)
+ unless (or (typep second-arg '(cons (eql :constant)))
+ (find '(integer 0 0) third-arg :test 'equal)
+ (equal second-arg
+ `(:or ,(sb-c::primitive-type-or-lose
+ 'sb-vm::positive-fixnum)
+ ,(sb-c::primitive-type-or-lose
+ 'fixnum))))
+ collect info))))))
+
+(with-test (:name :maybe-inline-ref-to-dead-lambda)
+ (compile nil `(lambda (string)
+ (declare (optimize speed (space 0)))
+ (cond ((every #'digit-char-p string)
+ nil)
+ ((some (lambda (c)
+ (digit-char-p c))
+ string))))))
+
+;; the x87 backend used to sometimes signal FP errors during boxing,
+;; because converting between double and single float values was a
+;; noop (fixed), and no doubt many remaining issues. We now store
+;; the value outside pseudo-atomic, so any SIGFPE should be handled
+;; corrrectly.
+;;
+;; When it fails, this test lands into ldb.
+(with-test (:name :no-overflow-during-allocation)
+ (handler-case (eval '(cosh 90))
+ (floating-point-overflow ()
+ t)))
+
+;; unbounded integer types could break integer arithmetic.
+(with-test (:name :bug-1199127)
+ (compile nil `(lambda (b)
+ (declare (type (integer -1225923945345 -832450738898) b))
+ (declare (optimize (speed 3) (space 3) (safety 2)
+ (debug 0) (compilation-speed 1)))
+ (loop for lv1 below 3
+ sum (logorc2
+ (if (>= 0 lv1)
+ (ash b (min 25 lv1))
+ 0)
+ -2)))))
+
+;; non-trivial modular arithmetic operations would evaluate to wider results
+;; than expected, and never be cut to the right final bitwidth.
+(with-test (:name :bug-1199428-1)
+ (let ((f1 (compile nil `(lambda (a c)
+ (declare (type (integer -2 1217810089) a))
+ (declare (type (integer -6895591104928 -561736648588) c))
+ (declare (optimize (speed 2) (space 0) (safety 2) (debug 0)
+ (compilation-speed 3)))
+ (logandc1 (gcd c)
+ (+ (- a c)
+ (loop for lv2 below 1 count t))))))
+ (f2 (compile nil `(lambda (a c)
+ (declare (notinline - + gcd logandc1))
+ (declare (optimize (speed 1) (space 1) (safety 0) (debug 1)
+ (compilation-speed 3)))
+ (logandc1 (gcd c)
+ (+ (- a c)
+ (loop for lv2 below 1 count t)))))))
+ (let ((a 530436387)
+ (c -4890629672277))
+ (assert (eql (funcall f1 a c)
+ (funcall f2 a c))))))
+
+(with-test (:name :bug-1199428-2)
+ (let ((f1 (compile nil `(lambda (a b)
+ (declare (type (integer -1869232508 -6939151) a))
+ (declare (type (integer -11466348357 -2645644006) b))
+ (declare (optimize (speed 1) (space 0) (safety 2) (debug 2)
+ (compilation-speed 2)))
+ (logand (lognand a -6) (* b -502823994)))))
+ (f2 (compile nil `(lambda (a b)
+ (logand (lognand a -6) (* b -502823994))))))
+ (let ((a -1491588365)
+ (b -3745511761))
+ (assert (eql (funcall f1 a b)
+ (funcall f2 a b))))))
+
+;; win32 is very specific about the order in which catch blocks
+;; must be allocated on the stack
+(with-test (:name :bug-1072739)
+ (let ((f (compile nil
+ `(lambda ()
+ (STRING=
+ (LET ((% 23))
+ (WITH-OUTPUT-TO-STRING (G13908)
+ (PRINC
+ (LET ()
+ (DECLARE (OPTIMIZE (SB-EXT:INHIBIT-WARNINGS 3)))
+ (HANDLER-CASE
+ (WITH-OUTPUT-TO-STRING (G13909) (PRINC %A%B% G13909) G13909)
+ (UNBOUND-VARIABLE NIL
+ (HANDLER-CASE
+ (WITH-OUTPUT-TO-STRING (G13914)
+ (PRINC %A%B% G13914)
+ (PRINC "" G13914)
+ G13914)
+ (UNBOUND-VARIABLE NIL
+ (HANDLER-CASE
+ (WITH-OUTPUT-TO-STRING (G13913)
+ (PRINC %A%B G13913)
+ (PRINC "%" G13913)
+ G13913)
+ (UNBOUND-VARIABLE NIL
+ (HANDLER-CASE
+ (WITH-OUTPUT-TO-STRING (G13912)
+ (PRINC %A% G13912)
+ (PRINC "b%" G13912)
+ G13912)
+ (UNBOUND-VARIABLE NIL
+ (HANDLER-CASE
+ (WITH-OUTPUT-TO-STRING (G13911)
+ (PRINC %A G13911)
+ (PRINC "%b%" G13911)
+ G13911)
+ (UNBOUND-VARIABLE NIL
+ (HANDLER-CASE
+ (WITH-OUTPUT-TO-STRING (G13910)
+ (PRINC % G13910)
+ (PRINC "a%b%" G13910)
+ G13910)
+ (UNBOUND-VARIABLE NIL
+ (ERROR "Interpolation error in \"%a%b%\"
+"))))))))))))))
+ G13908)))
+ "23a%b%")))))
+ (assert (funcall f))))
+
+(with-test (:name :equal-equalp-transforms)
+ (let* ((s "foo")
+ (bit-vector #*11001100)
+ (values `(nil 1 2 "test"
+ ;; Floats duplicated here to ensure we get newly created instances
+ (read-from-string "1.1") (read-from-string "1.2d0")
+ (read-from-string "1.1") (read-from-string "1.2d0")
+ 1.1 1.2d0 '("foo" "bar" "test")
+ #(1 2 3 4) #*101010 (make-broadcast-stream) #p"/tmp/file"
+ ,s (copy-seq ,s) ,bit-vector (copy-seq ,bit-vector)
+ ,(make-hash-table) #\a #\b #\A #\C
+ ,(make-random-state) 1/2 2/3)))
+ ;; Test all permutations of different types
+ (assert
+ (loop
+ for x in values
+ always (loop
+ for y in values
+ always
+ (and (eq (funcall (compile nil `(lambda (x y)
+ (equal (the ,(type-of x) x)
+ (the ,(type-of y) y))))
+ x y)
+ (equal x y))
+ (eq (funcall (compile nil `(lambda (x y)
+ (equalp (the ,(type-of x) x)
+ (the ,(type-of y) y))))
+ x y)
+ (equalp x y))))))
+ (assert
+ (funcall (compile
+ nil
+ `(lambda (x y)
+ (equal (the (cons (or simple-bit-vector simple-base-string))
+ x)
+ (the (cons (or (and bit-vector (not simple-array))
+ (simple-array character (*))))
+ y))))
+ (list (string 'list))
+ (list "LIST")))
+ (assert
+ (funcall (compile
+ nil
+ `(lambda (x y)
+ (equalp (the (cons (or simple-bit-vector simple-base-string))
+ x)
+ (the (cons (or (and bit-vector (not simple-array))
+ (simple-array character (*))))
+ y))))
+ (list (string 'list))
+ (list "lisT")))))
+
+(with-test (:name (restart-case optimize speed compiler-note))
+ (handler-bind ((compiler-note #'error))
+ (compile nil '(lambda ()
+ (declare (optimize speed))
+ (restart-case () (c ()))))
+ (compile nil '(lambda ()
+ (declare (optimize speed))
+ (let (x)
+ (restart-case (setf x (car (compute-restarts)))
+ (c ()))
+ x)))))
+
+(with-test (:name :copy-more-arg
+ :fails-on '(not (or :x86 :x86-64)))
+ ;; copy-more-arg might not copy in the right direction
+ ;; when there are more fixed args than stack frame slots,
+ ;; and thus end up splatting a single argument everywhere.
+ ;; Fixed on x86oids only, but other platforms still start
+ ;; their stack frames at 8 slots, so this is less likely
+ ;; to happen.
+ (let ((limit 33))
+ (labels ((iota (n)
+ (loop for i below n collect i))
+ (test-function (function skip)
+ ;; function should just be (subseq x skip)
+ (loop for i from skip below (+ skip limit) do
+ (let* ((values (iota i))
+ (f (apply function values))
+ (subseq (subseq values skip)))
+ (assert (equal f subseq)))))
+ (make-function (n)
+ (let ((gensyms (loop for i below n collect (gensym))))
+ (compile nil `(lambda (,@gensyms &rest rest)
+ (declare (ignore ,@gensyms))
+ rest)))))
+ (dotimes (i limit)
+ (test-function (make-function i) i)))))
+
+(with-test (:name :apply-aref)
+ (flet ((test (form)
+ (let (warning)
+ (handler-bind ((warning (lambda (c) (setf warning c))))
+ (compile nil `(lambda (x y) (setf (apply #'sbit x y) 10))))
+ (assert (not warning)))))
+ (test `(lambda (x y) (setf (apply #'aref x y) 21)))
+ (test `(lambda (x y) (setf (apply #'bit x y) 1)))
+ (test `(lambda (x y) (setf (apply #'sbit x y) 0)))))
+
+(with-test (:name :warn-on-the-values-constant)
+ (multiple-value-bind (fun warnings-p failure-p)
+ (compile nil
+ ;; The compiler used to elide this test without
+ ;; noting that the type demands multiple values.
+ '(lambda () (the (values fixnum fixnum) 1)))
+ (declare (ignore warnings-p))
+ (assert (functionp fun))
+ (assert failure-p)))
+
+;; quantifiers shouldn't cons themselves.
+(with-test (:name :quantifiers-no-consing)
+ (let ((constantly-t (lambda (x) x t))
+ (constantly-nil (lambda (x) x nil))
+ (list (make-list 1000 :initial-element nil))
+ (vector (make-array 1000 :initial-element nil)))
+ (macrolet ((test (quantifier)
+ (let ((function (make-symbol (format nil "TEST-~A" quantifier))))
+ `(flet ((,function (function sequence)
+ (,quantifier function sequence)))
+ (ctu:assert-no-consing (,function constantly-t list))
+ (ctu:assert-no-consing (,function constantly-nil vector))))))
+ (test some)
+ (test every)
+ (test notany)
+ (test notevery))))
projects / sbcl.git / blobdiff