X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Fcompiler.pure.lisp;h=7cb31f28cc304e830c9dd02b202bb40557456431;hb=1af3faa2b79125b774c2182cab841ed7ee555bed;hp=cadd0b07358dc2978b012fe9005b08af59903c66;hpb=f22313c8b2cb104a088b8d901688f73c20a6161a;p=sbcl.git diff --git a/tests/compiler.pure.lisp b/tests/compiler.pure.lisp index cadd0b0..7cb31f2 100644 --- a/tests/compiler.pure.lisp +++ b/tests/compiler.pure.lisp @@ -1440,3 +1440,381 @@ (type (unsigned-byte 32) x y)) (logand #xffffffff (ash x y)))) 1 257))) + +;;; code instrumenting problems +(compile nil + '(lambda () + (declare (optimize (debug 3))) + (list (the integer (if nil 14 t))))) + +(compile nil + '(LAMBDA (A B C D) + (DECLARE (NOTINLINE LOGORC1 BYTE MASK-FIELD)) + (DECLARE + (OPTIMIZE (SPEED 1) + (SPACE 1) + (SAFETY 1) + (DEBUG 3) + (COMPILATION-SPEED 0))) + (MASK-FIELD (BYTE 7 26) + (PROGN + (TAGBODY (THE INTEGER (CATCH 'CT4 (LOGORC1 C -15950))) 1) + B)))) + +(compile nil + '(lambda (buffer i end) + (declare (optimize (debug 3))) + (loop (when (not (eql 0 end)) (return))) + (let ((s (make-string end))) + (setf (schar s i) (schar buffer i)) + s))) + +;;; check that constant string prefix and suffix don't cause the +;;; compiler to emit code deletion notes. +(handler-bind ((sb-ext:code-deletion-note #'error)) + (compile nil '(lambda (s x) + (pprint-logical-block (s x :prefix "(") + (print x s)))) + (compile nil '(lambda (s x) + (pprint-logical-block (s x :per-line-prefix ";") + (print x s)))) + (compile nil '(lambda (s x) + (pprint-logical-block (s x :suffix ">") + (print x s))))) + +;;; MISC.427: loop analysis requires complete DFO structure +(assert (eql 17 (funcall + (compile + nil + '(lambda (a) + (declare (notinline list reduce logior)) + (declare (optimize (safety 2) (compilation-speed 1) + (speed 3) (space 2) (debug 2))) + (logior + (let* ((v5 (reduce #'+ (list 0 a)))) + (declare (dynamic-extent v5)) + v5)))) + 17))) + +;;; MISC.434 +(assert (zerop (funcall + (compile + nil + '(lambda (a b) + (declare (type (integer -8431780939320 1571817471932) a)) + (declare (type (integer -4085 0) b)) + (declare (ignorable a b)) + (declare + (optimize (space 2) + (compilation-speed 0) + #+sbcl (sb-c:insert-step-conditions 0) + (debug 2) + (safety 0) + (speed 3))) + (let ((*s5* 0)) + (dotimes (iv1 2 0) + (let ((*s5* + (elt '(1954479092053) + (min 0 + (max 0 + (if (< iv1 iv1) + (lognand iv1 (ash iv1 (min 53 iv1))) + iv1)))))) + 0))))) + -7639589303599 -1368))) + +(compile + nil + '(lambda (a b) + (declare (type (integer) a)) + (declare (type (integer) b)) + (declare (ignorable a b)) + (declare (optimize (space 2) (compilation-speed 0) + (debug 0) (safety 0) (speed 3))) + (dotimes (iv1 2 0) + (when (< iv1 2) (print 'x)) ;; request for second constraint propagation pass + (print (if (< iv1 iv1) + (logand (ash iv1 iv1) 1) + iv1))))) + +;;; MISC.435: lambda var substitution in a deleted code. +(assert (zerop (funcall + (compile + nil + '(lambda (a b c d) + (declare (notinline aref logandc2 gcd make-array)) + (declare + (optimize (space 0) (safety 0) (compilation-speed 3) + (speed 3) (debug 1))) + (progn + (tagbody + (let* ((v2 (make-array nil :initial-element (catch 'ct1 (go tag2))))) + (declare (dynamic-extent v2)) + (gcd (go tag2) (logandc2 (catch 'ct2 c) (aref v2)))) + tag2) + 0))) + 3021871717588 -866608 -2 -17194))) + +;;; MISC.436, 438: lost reoptimization +(assert (zerop (funcall + (compile + nil + '(lambda (a b) + (declare (type (integer -2917822 2783884) a)) + (declare (type (integer 0 160159) b)) + (declare (ignorable a b)) + (declare + (optimize (compilation-speed 1) + (speed 3) + (safety 3) + (space 0) + ; #+sbcl (sb-c:insert-step-conditions 0) + (debug 0))) + (if + (oddp + (loop for + lv1 + below + 2 + count + (logbitp 0 + (1- + (ash b + (min 8 + (count 0 + '(-10197561 486 430631291 + 9674068)))))))) + b + 0))) + 1265797 110757))) + +(assert (zerop (funcall + (compile + nil + ' (lambda (a) + (declare (type (integer 0 1696) a)) + ; (declare (ignorable a)) + (declare (optimize (space 2) (debug 0) (safety 1) + (compilation-speed 0) (speed 1))) + (if (logbitp 0 (ash (1- a) (min 11 a))) 0 0))) + 805))) + +;;; bug #302 +(assert (compile + nil + '(lambda (s ei x y) + (declare (type (simple-array function (2)) s) (type ei ei)) + (funcall (aref s ei) x y)))) + +;;; MISC.320: ir1-transform can create an intercomponent reference to +;;; a DEFINED-FUN. +(assert (eql 102 (funcall + (compile + nil + '(lambda () + (declare (optimize (speed 3) (space 0) (safety 2) + (debug 2) (compilation-speed 0))) + (catch 'ct2 + (elt '(102) + (flet ((%f12 () (rem 0 -43))) + (multiple-value-call #'%f12 (values)))))))))) + +;;; MISC.437: lost reoptimization after FLUSH-DEST +(assert (zerop (funcall + (compile + nil + '(lambda (a b c d e) + (declare (notinline values complex eql)) + (declare + (optimize (compilation-speed 3) + (speed 3) + (debug 1) + (safety 1) + (space 0))) + (flet ((%f10 + (f10-1 f10-2 f10-3 + &optional (f10-4 (ignore-errors 0)) (f10-5 0) + &key &allow-other-keys) + (if (or (eql 0 0) t) 0 (if f10-1 0 0)))) + (complex (multiple-value-call #'%f10 (values a c b 0 0)) 0)))) + 80043 74953652306 33658947 -63099937105 -27842393))) + +;;; bug #351 -- program-error for malformed LET and LET*, including those +;;; resulting from SETF of LET. +(dolist (fun (list (compile nil '(lambda () (let :bogus-let :oops))) + (compile nil '(lambda () (let* :bogus-let* :oops))) + (compile nil '(lambda (x) (push x (let ((y 0)) y)))))) + (assert (functionp fun)) + (multiple-value-bind (res err) (ignore-errors (funcall fun)) + (assert (not res)) + (assert (typep err 'program-error)))) + +(let ((fun (compile nil '(lambda (x) (random (if x 10 20)))))) + (dotimes (i 100 (error "bad RANDOM distribution")) + (when (> (funcall fun nil) 9) + (return t))) + (dotimes (i 100) + (when (> (funcall fun t) 9) + (error "bad RANDOM event")))) + +;;; 0.8.17.28-sma.1 lost derived type information. +(handler-bind ((sb-ext:compiler-note #'error)) + (compile nil + '(lambda (x y v) + (declare (optimize (speed 3) (safety 0))) + (declare (type (integer 0 80) x) + (type (integer 0 11) y) + (type (simple-array (unsigned-byte 32) (*)) v)) + (setf (aref v 0) (* (* x #.(floor (ash 1 32) (* 11 80))) y)) + nil))) + +;;; Bug reported by Robert J. Macomber: instrumenting of more-entry +;;; prevented open coding of %LISTIFY-REST-ARGS. +(let ((f (compile nil '(lambda () + (declare (optimize (debug 3))) + (with-simple-restart (blah "blah") (error "blah")))))) + (handler-bind ((error (lambda (c) (invoke-restart 'blah)))) + (assert (equal (multiple-value-list (funcall f)) '(nil t))))) + +;;; Bug reported by Timmy Douglas: overflow in bit vector setter with +;;; constant index and value. +(loop for n-bits = 1 then (* n-bits 2) + for type = `(unsigned-byte ,n-bits) + and v-max = (1- (ash 1 n-bits)) + while (<= n-bits sb-vm:n-word-bits) + do + (let* ((n (* 2 (1+ (- sb-vm::n-word-bits n-bits)))) + (array1 (make-array n :element-type type)) + (array2 (make-array n :element-type type))) + (dotimes (i n) + (dolist (v (list 0 v-max)) + (let ((f (compile nil `(lambda (a) + (declare (type (simple-array ,type (,n)) a)) + (setf (aref a ,i) ,v))))) + (fill array1 (- v-max v)) + (fill array2 (- v-max v)) + (funcall f array1) + (setf (aref array2 i) v) + (assert (every #'= array1 array2))))))) + +(let ((fn (compile nil '(lambda (x) + (declare (type bit x)) + (declare (optimize speed)) + (let ((b (make-array 64 :element-type 'bit + :initial-element 0))) + (count x b)))))) + (assert (= (funcall fn 0) 64)) + (assert (= (funcall fn 1) 0))) + +(let ((fn (compile nil '(lambda (x y) + (declare (type simple-bit-vector x y)) + (declare (optimize speed)) + (equal x y))))) + (assert (funcall + fn + (make-array 64 :element-type 'bit :initial-element 0) + (make-array 64 :element-type 'bit :initial-element 0))) + (assert (not + (funcall + fn + (make-array 64 :element-type 'bit :initial-element 0) + (let ((b (make-array 64 :element-type 'bit :initial-element 0))) + (setf (sbit b 63) 1) + b))))) + +;;; MISC.535: compiler failure +(let ((c0 #c(4196.088977268509d0 -15943.3603515625d0))) + (assert (not (funcall + (compile + nil + `(lambda (p1 p2) + (declare (optimize speed (safety 1)) + (type (eql ,c0) p1) + (type number p2)) + (eql (the (complex double-float) p1) p2))) + c0 #c(12 612/979))))) + +;;; reported by Lutz Euler: we shouldn't signal a compiler note for +;;; simple-bit-vector functions. +(handler-bind ((sb-ext:compiler-note #'error)) + (compile nil '(lambda (x) + (declare (type simple-bit-vector x)) + (count 1 x)))) +(handler-bind ((sb-ext:compiler-note #'error)) + (compile nil '(lambda (x y) + (declare (type simple-bit-vector x y)) + (equal x y)))) + +;;; MISC.550: CAST merging in IR1 finalization caused unexpected +;;; code transformations. +(assert (eql (funcall + (compile + nil + '(lambda (p1 p2) + (declare (optimize (speed 3) (safety 2) (debug 3) (space 3)) + (type atom p1) + (type symbol p2)) + (or p1 (the (eql t) p2)))) + nil t) + t)) + +;;; MISC.548: type check weakening converts required type into +;;; optional +(assert (eql t + (funcall + (compile + nil + '(lambda (p1) + (declare (optimize (speed 2) (safety 1) (debug 3) (space 2))) + (atom (the (member f assoc-if write-line t w) p1)))) + t))) + +;;; Free special bindings only apply to the body of the binding form, not +;;; the initialization forms. +(assert (eq :good + (funcall (compile 'nil + (lambda () + (let ((x :bad)) + (declare (special x)) + (let ((x :good)) + ((lambda (&optional (y x)) + (declare (special x)) y))))))))) + +;;; Bug from pfdietz's random tester: the compiler knew that IMAGPART of +;;; a rational was zero, but didn't do the substitution, leading to a +;;; crash in the ASH vop (since a shift of 57 wouldn't fit in the +;;; machine's ASH instruction's immediate field) that the compiler +;;; thought was legitimate. +;;; +;;; FIXME: this has been recorded as bug 383. The attempted fix (sbcl +;;; 0.9.2.6) led to lots of spurious optimization notes. So the bug stil +;;; exist and this test case serves as a reminder of the problem. +;;; --njf, 2005-07-05 +#+nil +(compile 'nil + (LAMBDA (B) + (DECLARE (TYPE (INTEGER -2 14) B)) + (DECLARE (IGNORABLE B)) + (ASH (IMAGPART B) 57))) + +;;; bug reported by Eduardo Mu\~noz +(multiple-value-bind (fun warnings failure) + (compile nil '(lambda (struct first) + (declare (optimize speed)) + (let* ((nodes (nodes struct)) + (bars (bars struct)) + (length (length nodes)) + (new (make-array length :fill-pointer 0))) + (vector-push first new) + (loop with i fixnum = 0 + for newl fixnum = (length new) + while (< newl length) do + (let ((oldl (length new))) + (loop for j fixnum from i below newl do + (dolist (n (node-neighbours (aref new j) bars)) + (unless (find n new) + (vector-push n new)))) + (setq i oldl))) + new))) + (declare (ignore fun warnings failure)) + (assert (not failure)))