X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Fcompiler.pure.lisp;h=5e9e754c926afd516b8642003de134da593e291b;hb=5a9a81ca693a7b82d810cbe725818cd96244099e;hp=d4608173a4348dc9fd8edb6464217da3858a4340;hpb=d4624e03c64b15a86594b12020da88d7e5167e4f;p=sbcl.git diff --git a/tests/compiler.pure.lisp b/tests/compiler.pure.lisp index d460817..5e9e754 100644 --- a/tests/compiler.pure.lisp +++ b/tests/compiler.pure.lisp @@ -13,6 +13,8 @@ (cl:in-package :cl-user) +(load "compiler-test-util.lisp") + ;; The tests in this file assume that EVAL will use the compiler (when (eq sb-ext:*evaluator-mode* :interpret) (invoke-restart 'run-tests::skip-file)) @@ -528,11 +530,19 @@ (funcall f y 1) (assert (equal y #*10)))) +;;; use of declared array types (handler-bind ((sb-ext:compiler-note #'error)) (compile nil '(lambda (x) - (declare (type (simple-array (simple-string 3) (5)) x)) + (declare (type (simple-array (simple-string 3) (5)) x) + (optimize speed)) (aref (aref x 0) 0)))) +(handler-bind ((sb-ext:compiler-note #'error)) + (compile nil '(lambda (x) + (declare (type (simple-array (simple-array bit (10)) (10)) x) + (optimize speed)) + (1+ (aref (aref x 0) 0))))) + ;;; compiler failure (let ((f (compile nil '(lambda (x) (typep x '(not (member 0d0))))))) (assert (funcall f 1d0))) @@ -774,6 +784,35 @@ (declare (type (integer 4303063 101130078) a)) (mask-field (byte 18 2) (ash a 77)))) 57132532))) +;;; rewrite the test case to get the unsigned-byte 32/64 +;;; implementation even after implementing some modular arithmetic +;;; with signed-byte 30: +(assert (= 0 (funcall + (compile nil + '(lambda (a) + (declare (type (integer 4303063 101130078) a)) + (mask-field (byte 30 2) (ash a 77)))) + 57132532))) +(assert (= 0 (funcall + (compile nil + '(lambda (a) + (declare (type (integer 4303063 101130078) a)) + (mask-field (byte 64 2) (ash a 77)))) + 57132532))) +;;; and a similar test case for the signed masking extension (not the +;;; final interface, so change the call when necessary): +(assert (= 0 (funcall + (compile nil + '(lambda (a) + (declare (type (integer 4303063 101130078) a)) + (sb-c::mask-signed-field 30 (ash a 77)))) + 57132532))) +(assert (= 0 (funcall + (compile nil + '(lambda (a) + (declare (type (integer 4303063 101130078) a)) + (sb-c::mask-signed-field 61 (ash a 77)))) + 57132532))) ;;; MISC.101 and MISC.103: FLUSH-DEST did not mark the USE's block for ;;; type check regeneration @@ -1947,7 +1986,7 @@ (bit #*1001101001001 (min 12 (max 0 lv3)))))))))))) -;;; MISC.624: erronous AVER in x86's %LOGBITP VOPs +;;; MISC.624: erroneous AVER in x86's %LOGBITP VOPs (assert (eql 0 (funcall (compile @@ -2287,3 +2326,1037 @@ t) t (error "~a" y))))) + +;;; Compiling W-P-O when the pinned objects are known to be fixnums +;;; or characters. +(compile nil '(lambda (x y) + (declare (fixnum y) (character x)) + (sb-sys:with-pinned-objects (x y) + (some-random-function)))) + +;;; *CHECK-CONSISTENCY* and TRULY-THE + +(with-test (:name :bug-423) + (let ((sb-c::*check-consistency* t)) + (handler-bind ((warning #'error)) + (flet ((make-lambda (type) + `(lambda (x) + ((lambda (z) + (if (listp z) + (let ((q (truly-the list z))) + (length q)) + (if (arrayp z) + (let ((q (truly-the vector z))) + (length q)) + (error "oops")))) + (the ,type x))))) + (compile nil (make-lambda 'list)) + (compile nil (make-lambda 'vector)))))) + +;;; this caused a momentary regression when an ill-adviced fix to +;;; bug 427 made ANY-REG suitable for primitive-type T: +;;; +;;; no :MOVE-ARG VOP defined to move # (SC SB-VM::SINGLE-REG) to # (SC SB-VM::ANY-REG) +;;; [Condition of type SIMPLE-ERROR] +(compile nil + '(lambda (frob) + (labels + ((%zig (frob) + (typecase frob + (double-float + (setf (sb-alien:deref (sb-alien:cast (sb-alien:sap-alien (unknown1) (* unsigned-char)) + (* double-float))) frob)) + (hash-table + (%zig (the (values (single-float (0.0) 1.0) &optional) (unknown2))) + nil)))) + (%zig)))) + +;;; non-required arguments in HANDLER-BIND +(assert (eq :oops (car (funcall (compile nil + '(lambda (x) + (block nil + (handler-bind ((error (lambda (&rest args) (return (cons :oops args))))) + (/ 2 x))))) + 0)))) + +;;; NIL is a legal function name +(assert (eq 'a (flet ((nil () 'a)) (nil)))) + +;;; misc.528 +(assert (null (let* ((x 296.3066f0) + (y 22717067) + (form `(lambda (r p2) + (declare (optimize speed (safety 1)) + (type (simple-array single-float nil) r) + (type (integer -9369756340 22717335) p2)) + (setf (aref r) (* ,x (the (eql 22717067) p2))) + (values))) + (r (make-array nil :element-type 'single-float)) + (expected (* x y))) + (funcall (compile nil form) r y) + (let ((actual (aref r))) + (unless (eql expected actual) + (list expected actual)))))) +;;; misc.529 +(assert (null (let* ((x -2367.3296f0) + (y 46790178) + (form `(lambda (r p2) + (declare (optimize speed (safety 1)) + (type (simple-array single-float nil) r) + (type (eql 46790178) p2)) + (setf (aref r) (+ ,x (the (integer 45893897) p2))) + (values))) + (r (make-array nil :element-type 'single-float)) + (expected (+ x y))) + (funcall (compile nil form) r y) + (let ((actual (aref r))) + (unless (eql expected actual) + (list expected actual)))))) + +;;; misc.556 +(assert (eql -1 + (funcall + (compile nil '(lambda (p1 p2) + (declare + (optimize (speed 1) (safety 0) + (debug 0) (space 0)) + (type (member 8174.8604) p1) + (type (member -95195347) p2)) + (floor p1 p2))) + 8174.8604 -95195347))) + +;;; misc.557 +(assert (eql -1 + (funcall + (compile + nil + '(lambda (p1) + (declare (optimize (speed 3) (safety 0) (debug 3) (space 1)) + (type (member -94430.086f0) p1)) + (floor (the single-float p1) 19311235))) + -94430.086f0))) + +;;; misc.558 +(assert (eql -1.0f0 + (funcall + (compile + nil + '(lambda (p1) + (declare (optimize (speed 1) (safety 2) + (debug 2) (space 3)) + (type (eql -39466.56f0) p1)) + (ffloor p1 305598613))) + -39466.56f0))) + +;;; misc.559 +(assert (eql 1 + (funcall + (compile + nil + '(lambda (p1) + (declare (optimize (speed 1) (safety 1) (debug 1) (space 2)) + (type (eql -83232.09f0) p1)) + (ceiling p1 -83381228))) + -83232.09f0))) + +;;; misc.560 +(assert (eql 1 + (funcall + (compile + nil + '(lambda (p1) + (declare (optimize (speed 1) (safety 1) + (debug 1) (space 0)) + (type (member -66414.414f0) p1)) + (ceiling p1 -63019173f0))) + -66414.414f0))) + +;;; misc.561 +(assert (eql 1.0f0 + (funcall + (compile + nil + '(lambda (p1) + (declare (optimize (speed 0) (safety 1) + (debug 0) (space 1)) + (type (eql 20851.398f0) p1)) + (fceiling p1 80839863))) + 20851.398f0))) + +;;; misc.581 +(assert (floatp + (funcall + (compile nil '(lambda (x) + (declare (type (eql -5067.2056) x)) + (+ 213734822 x))) + -5067.2056))) + +;;; misc.581a +(assert (typep + (funcall + (compile nil '(lambda (x) (declare (type (eql -1.0) x)) + (+ #x1000001 x))) + -1.0f0) + 'single-float)) + +;;; misc.582 +(assert (plusp (funcall + (compile + nil + ' (lambda (p1) + (declare (optimize (speed 0) (safety 1) (debug 1) (space 1)) + (type (eql -39887.645) p1)) + (mod p1 382352925))) + -39887.645))) + +;;; misc.587 +(assert (let ((result (funcall + (compile + nil + '(lambda (p2) + (declare (optimize (speed 0) (safety 3) (debug 1) (space 0)) + (type (eql 33558541) p2)) + (- 92215.266 p2))) + 33558541))) + (typep result 'single-float))) + +;;; misc.635 +(assert (eql 1 + (let* ((form '(lambda (p2) + (declare (optimize (speed 0) (safety 1) + (debug 2) (space 2)) + (type (member -19261719) p2)) + (ceiling -46022.094 p2)))) + (values (funcall (compile nil form) -19261719))))) + +;;; misc.636 +(assert (let* ((x 26899.875) + (form `(lambda (p2) + (declare (optimize (speed 3) (safety 1) (debug 3) (space 1)) + (type (member ,x #:g5437 char-code #:g5438) p2)) + (* 104102267 p2)))) + (floatp (funcall (compile nil form) x)))) + +;;; misc.622 +(assert (eql + (funcall + (compile + nil + '(lambda (p2) + (declare (optimize (speed 3) (safety 2) (debug 3) (space 0)) + (type real p2)) + (+ 81535869 (the (member 17549.955 #:g35917) p2)))) + 17549.955) + (+ 81535869 17549.955))) + +;;; misc.654 +(assert (eql 2 + (let ((form '(lambda (p2) + (declare (optimize (speed 0) (safety 2) (debug 0) (space 2)) + (type (member integer eql) p2)) + (coerce 2 p2)))) + (funcall (compile nil form) 'integer)))) + +;;; misc.656 +(assert (eql 2 + (let ((form '(lambda (p2) + (declare (optimize (speed 0) (safety 2) (debug 0) (space 2)) + (type (member integer mod) p2)) + (coerce 2 p2)))) + (funcall (compile nil form) 'integer)))) + +;;; misc.657 +(assert (eql 2 + (let ((form '(lambda (p2) + (declare (optimize (speed 0) (safety 2) (debug 0) (space 2)) + (type (member integer values) p2)) + (coerce 2 p2)))) + (funcall (compile nil form) 'integer)))) + +(with-test (:name :string-aref-type) + (assert (eq 'character + (funcall (compile nil + '(lambda (s) + (ctu:compiler-derived-type (aref (the string s) 0)))) + "foo")))) + +(with-test (:name :base-string-aref-type) + (assert (eq #+sb-unicode 'base-char + #-sb-unicode 'character + (funcall (compile nil + '(lambda (s) + (ctu:compiler-derived-type (aref (the base-string s) 0)))) + (coerce "foo" 'base-string))))) + +(with-test (:name :dolist-constant-type-derivation) + (assert (equal '(integer 1 3) + (funcall (compile nil + '(lambda (x) + (dolist (y '(1 2 3)) + (when x + (return (ctu:compiler-derived-type y)))))) + t)))) + +(with-test (:name :dolist-simple-list-type-derivation) + (assert (equal '(integer 1 3) + (funcall (compile nil + '(lambda (x) + (dolist (y (list 1 2 3)) + (when x + (return (ctu:compiler-derived-type y)))))) + t)))) + +(with-test (:name :dolist-dotted-constant-list-type-derivation) + (let* ((warned nil) + (fun (handler-bind ((style-warning (lambda (c) (push c warned)))) + (compile nil + '(lambda (x) + (dolist (y '(1 2 3 . 4) :foo) + (when x + (return (ctu:compiler-derived-type y))))))))) + (assert (equal '(integer 1 3) (funcall fun t))) + (assert (= 1 (length warned))) + (multiple-value-bind (res err) (ignore-errors (funcall fun nil)) + (assert (not res)) + (assert (typep err 'type-error))))) + +(with-test (:name :constant-list-destructuring) + (handler-bind ((sb-ext:compiler-note #'error)) + (progn + (assert (= 10 + (funcall + (compile nil + '(lambda () + (destructuring-bind (a (b c) d) '(1 (2 3) 4) + (+ a b c d))))))) + (assert (eq :feh + (funcall + (compile nil + '(lambda (x) + (or x + (destructuring-bind (a (b c) d) '(1 "foo" 4) + (+ a b c d))))) + :feh)))))) + +;;; Functions with non-required arguments used to end up with +;;; (&OPTIONAL-DISPATCH ...) as their names. +(with-test (:name :hairy-function-name) + (assert (eq 'read-line (nth-value 2 (function-lambda-expression #'read-line)))) + (assert (equal "#" (princ-to-string #'read-line)))) + +;;; PROGV + RESTRICT-COMPILER-POLICY +(with-test (:name :progv-and-restrict-compiler-policy) + (let ((sb-c::*policy-restrictions* sb-c::*policy-restrictions*)) + (restrict-compiler-policy 'debug 3) + (let ((fun (compile nil '(lambda (x) + (let ((i x)) + (declare (special i)) + (list i + (progv '(i) (list (+ i 1)) + i) + i)))))) + (assert (equal '(1 2 1) (funcall fun 1)))))) + +;;; It used to be possible to confuse the compiler into +;;; IR2-converting such a call to CONS +(with-test (:name :late-bound-primitive) + (compile nil `(lambda () + (funcall 'cons 1)))) + +(with-test (:name :hairy-array-element-type-derivation) + (compile nil '(lambda (x) + (declare (type (and simple-string (satisfies array-has-fill-pointer-p)) x)) + (array-element-type x)))) + +(with-test (:name :rest-list-type-derivation) + (multiple-value-bind (type derivedp) + (funcall (compile nil `(lambda (&rest args) + (ctu:compiler-derived-type args))) + nil) + (assert (eq 'list type)) + (assert derivedp))) + +(with-test (:name :base-char-typep-elimination) + (assert (eq (funcall (lambda (ch) + (declare (type base-char ch) (optimize (speed 3) (safety 0))) + (typep ch 'base-char)) + t) + t))) + +(with-test (:name :regression-1.0.24.37) + (compile nil '(lambda (&key (test (constantly t))) + (when (funcall test) + :quux)))) + +;;; Attempt to test a decent cross section of conditions +;;; and values types to move conditionally. +(macrolet + ((test-comparison (comparator type x y) + `(progn + ,@(loop for (result-type a b) + in '((nil t nil) + (nil 0 1) + (nil 0.0 1.0) + (nil 0d0 0d0) + (nil 0.0 0d0) + (nil #c(1.0 1.0) #c(2.0 2.0)) + + (t t nil) + (fixnum 0 1) + ((unsigned-byte #.sb-vm:n-word-bits) + (1+ most-positive-fixnum) + (+ 2 most-positive-fixnum)) + ((signed-byte #.sb-vm:n-word-bits) + -1 (* 2 most-negative-fixnum)) + (single-float 0.0 1.0) + (double-float 0d0 1d0)) + for lambda = (if result-type + `(lambda (x y a b) + (declare (,type x y) + (,result-type a b)) + (if (,comparator x y) + a b)) + `(lambda (x y) + (declare (,type x y)) + (if (,comparator x y) + ,a ,b))) + for args = `(,x ,y ,@(and result-type + `(,a ,b))) + collect + `(progn + (eql (funcall (compile nil ',lambda) + ,@args) + (eval '(,lambda ,@args)))))))) + (sb-vm::with-float-traps-masked + (:divide-by-zero :overflow :inexact :invalid) + (let ((sb-ext:*evaluator-mode* :interpret)) + (declare (sb-ext:muffle-conditions style-warning)) + (test-comparison eql t t nil) + (test-comparison eql t t t) + + (test-comparison = t 1 0) + (test-comparison = t 1 1) + (test-comparison = t (1+ most-positive-fixnum) (+ 2 most-positive-fixnum)) + (test-comparison = fixnum 1 0) + (test-comparison = fixnum 0 0) + (test-comparison = (unsigned-byte #.sb-vm:n-word-bits) 1 0) + (test-comparison = (unsigned-byte #.sb-vm:n-word-bits) 0 0) + (test-comparison = (signed-byte #.sb-vm:n-word-bits) 1 0) + (test-comparison = (signed-byte #.sb-vm:n-word-bits) 1 1) + + (test-comparison = single-float 0.0 1.0) + (test-comparison = single-float 1.0 1.0) + (test-comparison = single-float (/ 1.0 0.0) (/ 1.0 0.0)) + (test-comparison = single-float (/ 1.0 0.0) 1.0) + (test-comparison = single-float (/ 0.0 0.0) (/ 0.0 0.0)) + (test-comparison = single-float (/ 0.0 0.0) 0.0) + + (test-comparison = double-float 0d0 1d0) + (test-comparison = double-float 1d0 1d0) + (test-comparison = double-float (/ 1d0 0d0) (/ 1d0 0d0)) + (test-comparison = double-float (/ 1d0 0d0) 1d0) + (test-comparison = double-float (/ 0d0 0d0) (/ 0d0 0d0)) + (test-comparison = double-float (/ 0d0 0d0) 0d0) + + (test-comparison < t 1 0) + (test-comparison < t 0 1) + (test-comparison < t 1 1) + (test-comparison < t (1+ most-positive-fixnum) (+ 2 most-positive-fixnum)) + (test-comparison < t (+ 2 most-positive-fixnum) (1+ most-positive-fixnum)) + (test-comparison < fixnum 1 0) + (test-comparison < fixnum 0 1) + (test-comparison < fixnum 0 0) + (test-comparison < (unsigned-byte #.sb-vm:n-word-bits) 1 0) + (test-comparison < (unsigned-byte #.sb-vm:n-word-bits) 0 1) + (test-comparison < (unsigned-byte #.sb-vm:n-word-bits) 0 0) + (test-comparison < (signed-byte #.sb-vm:n-word-bits) 1 0) + (test-comparison < (signed-byte #.sb-vm:n-word-bits) 0 1) + (test-comparison < (signed-byte #.sb-vm:n-word-bits) 1 1) + + (test-comparison < single-float 0.0 1.0) + (test-comparison < single-float 1.0 0.0) + (test-comparison < single-float 1.0 1.0) + (test-comparison < single-float (/ 1.0 0.0) (/ 1.0 0.0)) + (test-comparison < single-float (/ 1.0 0.0) 1.0) + (test-comparison < single-float 1.0 (/ 1.0 0.0)) + (test-comparison < single-float (/ 0.0 0.0) (/ 0.0 0.0)) + (test-comparison < single-float (/ 0.0 0.0) 0.0) + + (test-comparison < double-float 0d0 1d0) + (test-comparison < double-float 1d0 0d0) + (test-comparison < double-float 1d0 1d0) + (test-comparison < double-float (/ 1d0 0d0) (/ 1d0 0d0)) + (test-comparison < double-float (/ 1d0 0d0) 1d0) + (test-comparison < double-float 1d0 (/ 1d0 0d0)) + (test-comparison < double-float (/ 0d0 0d0) (/ 0d0 0d0)) + (test-comparison < double-float (/ 0d0 0d0) 0d0) + (test-comparison < double-float 0d0 (/ 0d0 0d0)) + + (test-comparison > t 1 0) + (test-comparison > t 0 1) + (test-comparison > t 1 1) + (test-comparison > t (1+ most-positive-fixnum) (+ 2 most-positive-fixnum)) + (test-comparison > t (+ 2 most-positive-fixnum) (1+ most-positive-fixnum)) + (test-comparison > fixnum 1 0) + (test-comparison > fixnum 0 1) + (test-comparison > fixnum 0 0) + (test-comparison > (unsigned-byte #.sb-vm:n-word-bits) 1 0) + (test-comparison > (unsigned-byte #.sb-vm:n-word-bits) 0 1) + (test-comparison > (unsigned-byte #.sb-vm:n-word-bits) 0 0) + (test-comparison > (signed-byte #.sb-vm:n-word-bits) 1 0) + (test-comparison > (signed-byte #.sb-vm:n-word-bits) 0 1) + (test-comparison > (signed-byte #.sb-vm:n-word-bits) 1 1) + + (test-comparison > single-float 0.0 1.0) + (test-comparison > single-float 1.0 0.0) + (test-comparison > single-float 1.0 1.0) + (test-comparison > single-float (/ 1.0 0.0) (/ 1.0 0.0)) + (test-comparison > single-float (/ 1.0 0.0) 1.0) + (test-comparison > single-float 1.0 (/ 1.0 0.0)) + (test-comparison > single-float (/ 0.0 0.0) (/ 0.0 0.0)) + (test-comparison > single-float (/ 0.0 0.0) 0.0) + + (test-comparison > double-float 0d0 1d0) + (test-comparison > double-float 1d0 0d0) + (test-comparison > double-float 1d0 1d0) + (test-comparison > double-float (/ 1d0 0d0) (/ 1d0 0d0)) + (test-comparison > double-float (/ 1d0 0d0) 1d0) + (test-comparison > double-float 1d0 (/ 1d0 0d0)) + (test-comparison > double-float (/ 0d0 0d0) (/ 0d0 0d0)) + (test-comparison > double-float (/ 0d0 0d0) 0d0) + (test-comparison > double-float 0d0 (/ 0d0 0d0))))) + +(with-test (:name :car-and-cdr-type-derivation-conservative) + (let ((f1 (compile nil + `(lambda (y) + (declare (optimize speed)) + (let ((x (the (cons fixnum fixnum) (cons 1 2)))) + (declare (type (cons t fixnum) x)) + (rplaca x y) + (+ (car x) (cdr x)))))) + (f2 (compile nil + `(lambda (y) + (declare (optimize speed)) + (let ((x (the (cons fixnum fixnum) (cons 1 2)))) + (setf (cdr x) y) + (+ (car x) (cdr x))))))) + (flet ((test-error (e value) + (assert (typep e 'type-error)) + (assert (eq 'number (type-error-expected-type e))) + (assert (eq value (type-error-datum e))))) + (let ((v1 "foo") + (v2 "bar")) + (multiple-value-bind (res err) (ignore-errors (funcall f1 v1)) + (assert (not res)) + (test-error err v1)) + (multiple-value-bind (res err) (ignore-errors (funcall f2 v2)) + (assert (not res)) + (test-error err v2)))))) + +(with-test (:name :array-dimension-derivation-conservative) + (let ((f (compile nil + `(lambda (x) + (declare (optimize speed)) + (declare (type (array * (4 4)) x)) + (let ((y x)) + (setq x (make-array '(4 4))) + (adjust-array y '(3 5)) + (array-dimension y 0)))))) + (assert (= 3 (funcall f (make-array '(4 4) :adjustable t)))))) + +(with-test (:name :with-timeout-code-deletion-note) + (handler-bind ((sb-ext:code-deletion-note #'error)) + (compile nil `(lambda () + (sb-ext:with-timeout 0 + (sleep 1)))))) + +(with-test (:name :full-warning-for-undefined-type-in-cl) + (assert (eq :full + (handler-case + (compile nil `(lambda (x) (the replace x))) + (style-warning () + :style) + (warning () + :full))))) + +(with-test (:name :single-warning-for-single-undefined-type) + (let ((n 0)) + (handler-bind ((warning (lambda (c) + (declare (ignore c)) + (incf n)))) + (compile nil `(lambda (x) (the #:no-type x))) + (assert (= 1 n)) + (compile nil `(lambda (x) (the 'fixnum x))) + (assert (= 2 n))))) + +(with-test (:name :complex-subtype-dumping-in-xc) + (assert + (= sb-vm:complex-single-float-widetag + (sb-kernel:widetag-of + (sb-vm:saetp-initial-element-default (sb-c::find-saetp '(complex single-float)))))) + (assert + (= sb-vm:complex-double-float-widetag + (sb-kernel:widetag-of + (sb-vm:saetp-initial-element-default (sb-c::find-saetp '(complex double-float))))))) + +(with-test (:name :complex-single-float-fill) + (assert (every (lambda (x) (= #c(1.0 2.0) x)) + (funcall + (compile nil + `(lambda (n x) + (make-array (list n) + :element-type '(complex single-float) + :initial-element x))) + 10 + #c(1.0 2.0))))) + +(with-test (:name :regression-1.0.28.21) + (let ((fun (compile nil `(lambda (x) (typep x '(simple-array * 1)))))) + (assert (funcall fun (vector 1 2 3))) + (assert (funcall fun "abc")) + (assert (not (funcall fun (make-array '(2 2))))))) + +(with-test (:name :no-silly-compiler-notes-from-character-function) + (let (current) + (handler-bind ((compiler-note (lambda (e) (error "~S: ~A" current e)))) + (dolist (name '(char-code char-int character char-name standard-char-p + graphic-char-p alpha-char-p upper-case-p lower-case-p + both-case-p digit-char-p alphanumericp digit-char-p)) + (setf current name) + (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 + char-not-lessp)) + (setf current name) + (compile nil `(lambda (x y) + (declare (character x y) (optimize speed)) + (,name x y))))))) + +;;; optimizing make-array +(with-test (:name (make-array :open-code-initial-contents)) + (assert (not (ctu:find-named-callees + (compile nil + `(lambda (x y z) + (make-array '(3) :initial-contents (list x y z))))))) + (assert (not (ctu:find-named-callees + (compile nil + `(lambda (x y z) + (make-array '3 :initial-contents (vector x y z))))))) + (assert (not (ctu:find-named-callees + (compile nil + `(lambda (x y z) + (make-array '3 :initial-contents `(,x ,y ,z)))))))) + +;;; optimizing array-in-bounds-p +(with-test (:name :optimize-array-in-bounds-p) + (locally + (macrolet ((find-callees (&body body) + `(ctu:find-named-callees + (compile nil + '(lambda () + ,@body)) + :name 'array-in-bounds-p)) + (must-optimize (&body exprs) + `(progn + ,@(loop for expr in exprs + collect `(assert (not (find-callees + ,expr)))))) + (must-not-optimize (&body exprs) + `(progn + ,@(loop for expr in exprs + collect `(assert (find-callees + ,expr)))))) + (must-optimize + ;; in bounds + (let ((a (make-array '(1)))) + (array-in-bounds-p a 0)) + ;; exceeds upper bound (constant) + (let ((a (make-array '(1)))) + (array-in-bounds-p a 1)) + ;; exceeds upper bound (interval) + (let ((a (make-array '(1)))) + (array-in-bounds-p a (+ 1 (random 2)))) + ;; negative lower bound (constant) + (let ((a (make-array '(1)))) + (array-in-bounds-p a -1)) + ;; negative lower bound (interval) + (let ((a (make-array 3)) + (i (- (random 1) 20))) + (array-in-bounds-p a i)) + ;; multiple known dimensions + (let ((a (make-array '(1 1)))) + (array-in-bounds-p a 0 0)) + ;; union types + (let ((s (the (simple-string 10) (eval "0123456789")))) + (array-in-bounds-p s 9))) + (must-not-optimize + ;; don't trust non-simple array length in safety=1 + (let ((a (the (array * (10)) (make-array 10 :adjustable t)))) + (eval `(adjust-array ,a 0)) + (array-in-bounds-p a 9)) + ;; same for a union type + (let ((s (the (string 10) (make-array 10 + :element-type 'character + :adjustable t)))) + (eval `(adjust-array ,s 0)) + (array-in-bounds-p s 9)) + ;; single unknown dimension + (let ((a (make-array (random 20)))) + (array-in-bounds-p a 10)) + ;; multiple unknown dimensions + (let ((a (make-array (list (random 20) (random 5))))) + (array-in-bounds-p a 5 2)) + ;; some other known dimensions + (let ((a (make-array (list 1 (random 5))))) + (array-in-bounds-p a 0 2)) + ;; subscript might be negative + (let ((a (make-array 5))) + (array-in-bounds-p a (- (random 3) 2))) + ;; subscript might be too large + (let ((a (make-array 5))) + (array-in-bounds-p a (random 6))) + ;; unknown upper bound + (let ((a (make-array 5))) + (array-in-bounds-p a (get-universal-time))) + ;; unknown lower bound + (let ((a (make-array 5))) + (array-in-bounds-p a (- (get-universal-time)))) + ;; in theory we should be able to optimize + ;; the following but the current implementation + ;; doesn't cut it because the array type's + ;; dimensions get reported as (* *). + (let ((a (make-array (list (random 20) 1)))) + (array-in-bounds-p a 5 2)))))) + +;;; optimizing (EXPT -1 INTEGER) +(test-util:with-test (:name (expt minus-one 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))) + (dotimes (i 12) + (if (oddp i) + (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)) + (disassembly (with-output-to-string (s) + (disassemble fun :stream s)))) + ;; Let's make sure there is no division at runtime: for x86 and + ;; x86-64 that implies an FDIV, DIVSS, or DIVSD instruction, so + ;; look for DIV in the disassembly. It's a terrible KLUDGE, but + ;; it works. + #+(or x86 x86-64) + (when check-insts + (assert (not (search "DIV" disassembly)))) + ;; No generic arithmetic! + (assert (not (search "GENERIC" disassembly))) + (assert (eql res (funcall fun arg)))))) + (dolist (c '(128 64 32 16 8 4 2 1 1/2 1/4 1/8 1/16 1/32 1/64)) + (dolist (type '(single-float double-float)) + (let* ((cf (coerce c type)) + (arg (- (random (* 2 cf)) cf)) + (r1 (eval `(/ ,arg ,cf))) + (r2 (eval `(/ ,arg ,(- cf))))) + (test `(lambda (x) (declare (,type x)) (/ x ,cf)) arg r1) + (test `(lambda (x) (declare (,type x)) (/ x ,(- cf))) arg r2) + ;; rational args should get optimized as well + (test `(lambda (x) (declare (,type x)) (/ x ,c)) arg r1) + (test `(lambda (x) (declare (,type x)) (/ x ,(- c))) arg r2)))) + ;; Also check that inexact reciprocals (1) are not used by default (2) are + ;; used with FLOAT-ACCURACY=0. + (dolist (type '(single-float double-float)) + (let ((trey (coerce 3 type)) + (one (coerce 1 type))) + (test `(lambda (x) (declare (,type x)) (/ x 3)) trey one + :check-insts nil) + (test `(lambda (x) + (declare (,type x) + (optimize (sb-c::float-accuracy 0))) + (/ x 3)) + trey (eval `(* ,trey (/ ,trey)))))))) + +(with-test (:name :float-multiplication-by-one) + (flet ((test (lambda-form arg &optional (result arg)) + (let* ((fun1 (compile nil lambda-form)) + (fun2 (funcall (compile nil `(lambda () + (declare (optimize (sb-c::float-accuracy 0))) + ,lambda-form)))) + (disassembly1 (with-output-to-string (s) + (disassemble fun1 :stream s))) + (disassembly2 (with-output-to-string (s) + (disassemble fun2 :stream s)))) + ;; Multiplication at runtime should be eliminated only with + ;; FLOAT-ACCURACY=0. (To catch SNaNs.) + #+(or x86 x86-64) + (assert (and (search "MUL" disassembly1) + (not (search "MUL" disassembly2)))) + ;; Not generic arithmetic, please! + (assert (and (not (search "GENERIC" disassembly1)) + (not (search "GENERIC" disassembly2)))) + (assert (eql result (funcall fun1 arg))) + (assert (eql result (funcall fun2 arg)))))) + (dolist (type '(single-float double-float)) + (let* ((one (coerce 1 type)) + (arg (random (* 2 one))) + (-r (- arg))) + (test `(lambda (x) (declare (,type x)) (* x 1)) arg) + (test `(lambda (x) (declare (,type x)) (* x -1)) arg -r) + (test `(lambda (x) (declare (,type x)) (* x ,one)) arg) + (test `(lambda (x) (declare (,type x)) (* x ,(- one))) arg -r))))) + +(with-test (:name :float-addition-of-zero) + (flet ((test (lambda-form arg &optional (result arg)) + (let* ((fun1 (compile nil lambda-form)) + (fun2 (funcall (compile nil `(lambda () + (declare (optimize (sb-c::float-accuracy 0))) + ,lambda-form)))) + (disassembly1 (with-output-to-string (s) + (disassemble fun1 :stream s))) + (disassembly2 (with-output-to-string (s) + (disassemble fun2 :stream s)))) + ;; Let's make sure there is no addition at runtime: for x86 and + ;; x86-64 that implies an FADD, ADDSS, or ADDSD instruction, so + ;; look for the ADDs in the disassembly. It's a terrible KLUDGE, + ;; but it works. Unless FLOAT-ACCURACY is zero, we leave the + ;; addition in to catch SNaNs. + #+x86 + (assert (and (search "FADD" disassembly1) + (not (search "FADD" disassembly2)))) + #+x86-64 + (let ((inst (if (typep result 'double-float) + "ADDSD" "ADDSS"))) + (assert (and (search inst disassembly1) + (not (search inst disassembly2))))) + (assert (eql result (funcall fun1 arg))) + (assert (eql result (funcall fun2 arg)))))) + (test `(lambda (x) (declare (single-float x)) (+ x 0)) 123.45) + (test `(lambda (x) (declare (single-float x)) (+ x 0.0)) 543.21) + (test `(lambda (x) (declare (single-float x)) (+ x 0.0d0)) 42.00 42.d0) + (test `(lambda (x) (declare (double-float x)) (+ x 0)) 123.45d0) + (test `(lambda (x) (declare (double-float x)) (+ x 0.0)) 543.21d0) + (test `(lambda (x) (declare (double-float x)) (+ x 0.0d0)) 42.d0))) + +(with-test (:name :float-substraction-of-zero) + (flet ((test (lambda-form arg &optional (result arg)) + (let* ((fun1 (compile nil lambda-form)) + (fun2 (funcall (compile nil `(lambda () + (declare (optimize (sb-c::float-accuracy 0))) + ,lambda-form)))) + (disassembly1 (with-output-to-string (s) + (disassemble fun1 :stream s))) + (disassembly2 (with-output-to-string (s) + (disassemble fun2 :stream s)))) + ;; Let's make sure there is no substraction at runtime: for x86 + ;; and x86-64 that implies an FSUB, SUBSS, or SUBSD instruction, + ;; so look for SUB in the disassembly. It's a terrible KLUDGE, + ;; but it works. Unless FLOAT-ACCURACY is zero, we leave the + ;; substraction in in to catch SNaNs. + #+x86 + (assert (and (search "FSUB" disassembly1) + (not (search "FSUB" disassembly2)))) + #+x86-64 + (let ((inst (if (typep result 'double-float) + "SUBSD" "SUBSS"))) + (assert (and (search inst disassembly1) + (not (search inst disassembly2))))) + (assert (eql result (funcall fun1 arg))) + (assert (eql result (funcall fun2 arg)))))) + (test `(lambda (x) (declare (single-float x)) (- x 0)) 123.45) + (test `(lambda (x) (declare (single-float x)) (- x 0.0)) 543.21) + (test `(lambda (x) (declare (single-float x)) (- x 0.0d0)) 42.00 42.d0) + (test `(lambda (x) (declare (double-float x)) (- x 0)) 123.45d0) + (test `(lambda (x) (declare (double-float x)) (- x 0.0)) 543.21d0) + (test `(lambda (x) (declare (double-float x)) (- x 0.0d0)) 42.d0))) + +(with-test (:name :float-multiplication-by-two) + (flet ((test (lambda-form arg &optional (result arg)) + (let* ((fun1 (compile nil lambda-form)) + (fun2 (funcall (compile nil `(lambda () + (declare (optimize (sb-c::float-accuracy 0))) + ,lambda-form)))) + (disassembly1 (with-output-to-string (s) + (disassemble fun1 :stream s))) + (disassembly2 (with-output-to-string (s) + (disassemble fun2 :stream s)))) + ;; Let's make sure there is no multiplication at runtime: for x86 + ;; and x86-64 that implies an FMUL, MULSS, or MULSD instruction, + ;; so look for MUL in the disassembly. It's a terrible KLUDGE, + ;; but it works. + #+(or x86 x86-64) + (assert (and (not (search "MUL" disassembly1)) + (not (search "MUL" disassembly2)))) + (assert (eql result (funcall fun1 arg))) + (assert (eql result (funcall fun2 arg)))))) + (test `(lambda (x) (declare (single-float x)) (* x 2)) 123.45 246.9) + (test `(lambda (x) (declare (single-float x)) (* x 2.0)) 543.21 1086.42) + (test `(lambda (x) (declare (single-float x)) (* x 2.0d0)) 42.00 84.d0) + (test `(lambda (x) (declare (double-float x)) (* x 2)) 123.45d0 246.9d0) + (test `(lambda (x) (declare (double-float x)) (* x 2.0)) 543.21d0 1086.42d0) + (test `(lambda (x) (declare (double-float x)) (* x 2.0d0)) 42.0d0 84.0d0))) + +(with-test (:name :bug-392203) + ;; Used to hit an AVER in COMVERT-MV-CALL. + (assert (zerop + (funcall + (compile nil + `(lambda () + (flet ((k (&rest x) (declare (ignore x)) 0)) + (multiple-value-call #'k #'k)))))))) + +(with-test (:name :allocate-closures-failing-aver) + (let ((f (compile nil `(lambda () + (labels ((k (&optional x) #'k))))))) + (assert (null (funcall f))))) + +(with-test (:name :flush-vector-creation) + (let ((f (compile nil `(lambda () + (dotimes (i 1024) + (vector i i i)) + t)))) + (ctu:assert-no-consing (funcall f)))) + +(with-test (:name :array-type-predicates) + (dolist (et sb-kernel::*specialized-array-element-types*) + (when et + (let* ((v (make-array 3 :element-type et)) + (fun (compile nil `(lambda () + (list + (if (typep ,v '(simple-array ,et (*))) + :good + :bad) + (if (typep (elt ,v 0) '(simple-array ,et (*))) + :bad + :good)))))) + (assert (equal '(:good :good) (funcall fun))))))) + +(with-test (:name :truncate-float) + (let ((s (compile nil `(lambda (x) + (declare (single-float x)) + (truncate x)))) + (d (compile nil `(lambda (x) + (declare (double-float x)) + (truncate x))))) + ;; Check that there is no generic arithmetic + (assert (not (search "GENERIC" + (with-output-to-string (out) + (disassemble s :stream out))))) + (assert (not (search "GENERIC" + (with-output-to-string (out) + (disassemble d :stream out))))))) + +(with-test (:name :make-array-unnamed-dimension-leaf) + (let ((fun (compile nil `(lambda (stuff) + (make-array (map 'list 'length stuff)))))) + (assert (equalp #2A((0 0 0) (0 0 0)) + (funcall fun '((1 2) (1 2 3))))))) + +(with-test (:name :fp-decoding-funs-not-flushable-in-safe-code) + (dolist (name '(float-sign float-radix float-digits float-precision decode-float + integer-decode-float)) + (let ((fun (compile nil `(lambda (x) + (declare (optimize safety)) + (,name x) + nil)))) + (flet ((test (arg) + (unless (eq :error + (handler-case + (funcall fun arg) + (error () :error))) + (error "(~S ~S) did not error" + name arg)))) + ;; No error + (funcall fun 1.0) + ;; Error + (test 'not-a-float) + (when (member name '(decode-float integer-decode-float)) + (test sb-ext:single-float-positive-infinity)))))) + +(with-test (:name :sap-ref-16) + (let* ((fun (compile nil `(lambda (x y) + (declare (type sb-sys:system-area-pointer x) + (type (integer 0 100) y)) + (sb-sys:sap-ref-16 x (+ 4 y))))) + (vector (coerce '(0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15) + '(simple-array (unsigned-byte 8) (*)))) + (sap (sb-sys:vector-sap vector)) + (ret (funcall fun sap 0))) + ;; test for either endianness + (assert (or (= ret (+ (* 5 256) 4)) (= ret (+ (* 4 256) 5)))))) + +(with-test (:name :coerce-type-warning) + (dolist (type '(t (unsigned-byte 8) (unsigned-byte 16) (unsigned-byte 32) + (signed-byte 8) (signed-byte 16) (signed-byte 32))) + (multiple-value-bind (fun warningsp failurep) + (compile nil `(lambda (x) + (declare (type simple-vector x)) + (coerce x '(vector ,type)))) + (assert (null warningsp)) + (assert (null failurep)) + (assert (typep (funcall fun #(1)) `(simple-array ,type (*))))))) + +(with-test (:name :truncate-double-float) + (let ((fun (compile nil `(lambda (x) + (multiple-value-bind (q r) + (truncate (coerce x 'double-float)) + (declare (type unsigned-byte q) + (type double-float r)) + (list q r)))))) + (assert (equal (funcall fun 1.0d0) '(1 0.0d0))))) + +(with-test (:name :set-slot-value-no-warning) + (let ((notes 0)) + (handler-bind ((warning #'error) + (sb-ext:compiler-note (lambda (c) + (declare (ignore c)) + (incf notes)))) + (compile nil `(lambda (x y) + (declare (optimize speed safety)) + (setf (slot-value x 'bar) y)))) + (assert (= 1 notes)))) + +(with-test (:name :concatenate-string-opt) + (flet ((test (type grep) + (let* ((fun (compile nil `(lambda (a b c d e) + (concatenate ',type a b c d e)))) + (args '("foo" #(#\.) "bar" (#\-) "quux")) + (res (apply fun args))) + (assert (search grep (with-output-to-string (out) + (disassemble fun :stream out)))) + (assert (equal (apply #'concatenate type args) + res)) + (assert (typep res type))))) + (test 'string "%CONCATENATE-TO-STRING") + (test 'simple-string "%CONCATENATE-TO-STRING") + (test 'base-string "%CONCATENATE-TO-BASE-STRING") + (test 'simple-base-string "%CONCATENATE-TO-BASE-STRING"))) + +(with-test (:name :satisfies-no-local-fun) + (let ((fun (compile nil `(lambda (arg) + (labels ((local-not-global-bug (x) + t) + (bar (x) + (typep x '(satisfies local-not-global-bug)))) + (bar arg)))))) + (assert (eq 'local-not-global-bug + (handler-case + (funcall fun 42) + (undefined-function (c) + (cell-error-name c)))))))