X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Fcompiler.pure.lisp;h=531acc1325ac8e4e461e343004d6f4079cfcef59;hb=0c0d8909984b5b33bb6b59b350b2d5cee6dc1715;hp=381bb2f6ae8a3e91b194b6a7be47ae80195ccb5f;hpb=f5522c7149744e4faf34313b18d0d3588d2a9d98;p=sbcl.git diff --git a/tests/compiler.pure.lisp b/tests/compiler.pure.lisp index 381bb2f..531acc1 100644 --- a/tests/compiler.pure.lisp +++ b/tests/compiler.pure.lisp @@ -11,18 +11,10 @@ ;;;; absolutely no warranty. See the COPYING and CREDITS files for ;;;; more information. -(cl:in-package :sb-c) - -(defknown compiler-derived-type (t) (values t t) (movable flushable unsafe)) - -(deftransform compiler-derived-type ((x)) - `(values ',(type-specifier (lvar-type x)) t)) - -(defun compiler-derived-type (x) - (values t nil)) - (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)) @@ -2585,7 +2577,7 @@ (assert (eq 'character (funcall (compile nil '(lambda (s) - (sb-c::compiler-derived-type (aref (the string s) 0)))) + (ctu:compiler-derived-type (aref (the string s) 0)))) "foo")))) (with-test (:name :base-string-aref-type) @@ -2593,7 +2585,7 @@ #-sb-unicode 'character (funcall (compile nil '(lambda (s) - (sb-c::compiler-derived-type (aref (the base-string s) 0)))) + (ctu:compiler-derived-type (aref (the base-string s) 0)))) (coerce "foo" 'base-string))))) (with-test (:name :dolist-constant-type-derivation) @@ -2602,7 +2594,7 @@ '(lambda (x) (dolist (y '(1 2 3)) (when x - (return (sb-c::compiler-derived-type y)))))) + (return (ctu:compiler-derived-type y)))))) t)))) (with-test (:name :dolist-simple-list-type-derivation) @@ -2611,7 +2603,7 @@ '(lambda (x) (dolist (y (list 1 2 3)) (when x - (return (sb-c::compiler-derived-type y)))))) + (return (ctu:compiler-derived-type y)))))) t)))) (with-test (:name :dolist-dotted-constant-list-type-derivation) @@ -2621,7 +2613,7 @@ '(lambda (x) (dolist (y '(1 2 3 . 4) :foo) (when x - (return (sb-c::compiler-derived-type y))))))))) + (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)) @@ -2675,3 +2667,894 @@ (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)))) + (s-inlined (compile nil '(lambda (x) + (declare (type (single-float 0.0s0 1.0s0) x)) + (truncate x)))) + (d-inlined (compile nil '(lambda (x) + (declare (type (double-float 0.0d0 1.0d0) 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))))) + ;; Check that we actually inlined the call when we were supposed to. + (assert (not (search "UNARY-TRUNCATE" + (with-output-to-string (out) + (disassemble s-inlined :stream out))))) + (assert (not (search "UNARY-TRUNCATE" + (with-output-to-string (out) + (disassemble d-inlined :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))))))) + +;;; Prior to 1.0.32.x, dumping a fasl with a function with a default +;;; argument that is a complex structure (needing make-load-form +;;; processing) failed an AVER. The first attempt at a fix caused +;;; doing the same in-core to break. +(with-test (:name :bug-310132) + (compile nil '(lambda (&optional (foo #p"foo/bar"))))) + +(with-test (:name :bug-309129) + (let* ((src '(lambda (v) (values (svref v 0) (vector-pop v)))) + (warningp nil) + (fun (handler-bind ((warning (lambda (c) + (setf warningp t) (muffle-warning c)))) + (compile nil src)))) + (assert warningp) + (handler-case (funcall fun #(1)) + (type-error (c) + ;; we used to put simply VECTOR into EXPECTED-TYPE, rather + ;; than explicitly (AND VECTOR (NOT SIMPLE-ARRAY)) + (assert (not (typep (type-error-datum c) (type-error-expected-type c))))) + (:no-error (&rest values) + (declare (ignore values)) + (error "no error"))))) + +(with-test (:name :unary-round-type-derivation) + (let* ((src '(lambda (zone) + (multiple-value-bind (h m) (truncate (abs zone) 1.0) + (declare (ignore h)) + (round (* 60.0 m))))) + (fun (compile nil src))) + (assert (= (funcall fun 0.5) 30)))) + +(with-test (:name :bug-525949) + (let* ((src '(lambda () + (labels ((always-one () 1) + (f (z) + (let ((n (funcall z))) + (declare (fixnum n)) + (the double-float (expt n 1.0d0))))) + (f #'always-one)))) + (warningp nil) + (fun (handler-bind ((warning (lambda (c) + (setf warningp t) (muffle-warning c)))) + (compile nil src)))) + (assert (not warningp)) + (assert (= 1.0d0 (funcall fun))))) + +(with-test (:name :%array-data-vector-type-derivation) + (let* ((f (compile nil + `(lambda (ary) + (declare (type (simple-array (unsigned-byte 32) (3 3)) ary)) + (setf (aref ary 0 0) 0)))) + (text (with-output-to-string (s) + (disassemble f :stream s)))) + (assert (not (search "OBJECT-NOT-SIMPLE-ARRAY-UNSIGNED-BYTE-32-ERROR" text))))) + +(with-test (:name :array-storage-vector-type-derivation) + (let ((f (compile nil + `(lambda (ary) + (declare (type (simple-array (unsigned-byte 32) (3 3)) ary)) + (ctu:compiler-derived-type (array-storage-vector ary)))))) + (assert (equal '(simple-array (unsigned-byte 32) (9)) + (funcall f (make-array '(3 3) :element-type '(unsigned-byte 32))))))) + +(with-test (:name :bug-523612) + (let ((fun + (compile nil + `(lambda (&key toff) + (make-array 3 :element-type 'double-float + :initial-contents + (if toff (list toff 0d0 0d0) (list 0d0 0d0 0d0))))))) + (assert (equalp (vector 0.0d0 0.0d0 0.0d0) (funcall fun :toff nil))) + (assert (equalp (vector 2.3d0 0.0d0 0.0d0) (funcall fun :toff 2.3d0))))) + +(with-test (:name :bug-309788) + (let ((fun + (compile nil + `(lambda (x) + (declare (optimize speed)) + (let ((env nil)) + (typep x 'fixnum env)))))) + (assert (not (ctu:find-named-callees fun))))) + +(with-test (:name :bug-309124) + (let ((fun + (compile nil + `(lambda (x) + (declare (integer x)) + (declare (optimize speed)) + (cond ((typep x 'fixnum) + "hala") + ((typep x 'fixnum) + "buba") + ((typep x 'bignum) + "hip") + (t + "zuz")))))) + (assert (equal (list "hala" "hip") + (sort (ctu:find-code-constants fun :type 'string) + #'string<))))) + +(with-test (:name :bug-316078) + (let ((fun + (compile nil + `(lambda (x) + (declare (type (and simple-bit-vector (satisfies bar)) x) + (optimize speed)) + (elt x 5))))) + (assert (not (ctu:find-named-callees fun))) + (assert (= 1 (funcall fun #*000001))) + (assert (= 0 (funcall fun #*000010))))) + +(with-test (:name :mult-by-one-in-float-acc-zero) + (assert (eql 1.0 (funcall (compile nil `(lambda (x) + (declare (optimize (sb-c::float-accuracy 0))) + (* x 1.0))) + 1))) + (assert (eql -1.0 (funcall (compile nil `(lambda (x) + (declare (optimize (sb-c::float-accuracy 0))) + (* x -1.0))) + 1))) + (assert (eql 1.0d0 (funcall (compile nil `(lambda (x) + (declare (optimize (sb-c::float-accuracy 0))) + (* x 1.0d0))) + 1))) + (assert (eql -1.0d0 (funcall (compile nil `(lambda (x) + (declare (optimize (sb-c::float-accuracy 0))) + (* x -1.0d0))) + 1)))) + +(with-test (:name :dotimes-non-integer-counter-value) + (assert (raises-error? (dotimes (i 8.6)) type-error))) + +(with-test (:name :bug-454681) + ;; This used to break due to reference to a dead lambda-var during + ;; inline expansion. + (assert (compile nil + `(lambda () + (multiple-value-bind (iterator+977 getter+978) + (does-not-exist-but-does-not-matter) + (flet ((iterator+976 () + (funcall iterator+977))) + (declare (inline iterator+976)) + (let ((iterator+976 #'iterator+976)) + (funcall iterator+976)))))))) + +(with-test (:name :complex-float-local-fun-args) + ;; As of 1.0.27.14, the lambda below failed to compile due to the + ;; compiler attempting to pass unboxed complex floats to Z and the + ;; MOVE-ARG method not expecting the register being used as a + ;; temporary frame pointer. Reported by sykopomp in #lispgames, + ;; reduced test case provided by _3b`. + (compile nil '(lambda (a) + (labels ((z (b c) + (declare ((complex double-float) b c)) + (* b (z b c)))) + (loop for i below 10 do + (setf a (z a a))))))) + +(with-test (:name :bug-309130) + (assert (eq :warning + (handler-case + (compile nil `(lambda () (svref (make-array 8 :adjustable t) 1))) + ((and warning (not style-warning)) () + :warning)))) + (assert (eq :warning + (handler-case + (compile nil `(lambda (x) + (declare (optimize (debug 0))) + (declare (type vector x)) + (list (fill-pointer x) (svref x 1)))) + ((and warning (not style-warning)) () + :warning)))) + (assert (eq :warning + (handler-case + (compile nil `(lambda (x) + (list (vector-push (svref x 0) x)))) + ((and warning (not style-warning)) () + :warning)))) + (assert (eq :warning + (handler-case + (compile nil `(lambda (x) + (list (vector-push-extend (svref x 0) x)))) + ((and warning (not style-warning)) () + :warning)))))