X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Fcompiler.pure.lisp;h=4325bd26d1869bde571173f27df9e04bd24a7566;hb=b41f8c974ccfba8a59ec2a6af843e8869e14be5f;hp=a0715b7d3e7b57ecff71a5ab9a0e64628ffa49e1;hpb=602c9b1f15e2d96e4b79a3341a734b5eb8e02093;p=sbcl.git

diff --git a/tests/compiler.pure.lisp b/tests/compiler.pure.lisp
index a0715b7..4325bd2 100644
--- a/tests/compiler.pure.lisp
+++ b/tests/compiler.pure.lisp
@@ -1234,6 +1234,31 @@
 (assert (equal (non-continuous-stack-test t) '(11 12 13 14 1 2 3 4 5 6 7 8 :ext)))
 (assert (equal (non-continuous-stack-test nil) '(:b1 :b2 :b3 :b4 :a1 :a2 :a3 :a4 :int)))
 
+;;; MISC.362: environment of UNWIND-PROTECTor is different from that
+;;; if ENTRY.
+(assert (equal (multiple-value-list (funcall
+   (compile
+    nil
+    '(lambda (b g h)
+       (declare (optimize (speed 3) (space 3) (safety 2)
+			  (debug 2) (compilation-speed 3)))
+       (catch 'ct5
+	 (unwind-protect
+	     (labels ((%f15 (f15-1 f15-2 f15-3)
+                            (rational (throw 'ct5 0))))
+	       (%f15 0
+		     (apply #'%f15
+			    0
+			    h
+			    (progn
+			      (progv '(*s2* *s5*) (list 0 (%f15 0 g 0)) b)
+			      0)
+			    nil)
+		     0))
+	   (common-lisp:handler-case 0)))))
+   1 2 3))
+ '(0)))
+
 
 ;;; MISC.275
 (assert
@@ -1329,3 +1354,428 @@
                 (debug 3) (compilation-speed 3)))
       (flet ((%f () (multiple-value-prog1 0 (return-from %f 0))))
         (complex (%f) 0)))))))
+
+;;; MISC.110A: CAST optimizer forgot to flush LVAR derived type
+(assert (zerop (funcall
+  (compile
+   nil
+   '(lambda (a c)
+     (declare (type (integer -1294746569 1640996137) a))
+     (declare (type (integer -807801310 3) c))
+     (declare (optimize (speed 3) (space 3) (safety 0) (debug 0) (compilation-speed 3)))
+     (catch 'ct7
+       (if
+        (logbitp 0
+                 (if (/= 0 a)
+                     c
+                     (ignore-errors
+                       (progn (if (ldb-test (byte 0 0) (rational (throw 'ct7 0))) 0 0) 0))))
+        0 0))))
+   391833530 -32785211)))
+
+;;; efficiency notes for ordinary code
+(macrolet ((frob (arglist &body body)
+	     `(progn
+	       (handler-case
+		   (compile nil '(lambda ,arglist ,@body))
+		 (sb-ext:compiler-note (e)
+		   (error "bad compiler note for ~S:~%  ~A" ',body e)))
+	       (catch :got-note
+		 (handler-case
+		     (compile nil '(lambda ,arglist (declare (optimize speed))
+				    ,@body))
+		   (sb-ext:compiler-note (e) (throw :got-note nil)))
+		 (error "missing compiler note for ~S" ',body)))))
+  (frob (x) (funcall x))
+  (frob (x y) (find x y))
+  (frob (x y) (find-if x y))
+  (frob (x y) (find-if-not x y))
+  (frob (x y) (position x y))
+  (frob (x y) (position-if x y))
+  (frob (x y) (position-if-not x y))
+  (frob (x) (aref x 0)))
+
+(macrolet ((frob (style-warn-p form)
+	     (if style-warn-p
+		 `(catch :got-style-warning
+		   (handler-case
+		       (eval ',form)
+		     (style-warning (e) (throw :got-style-warning nil)))
+		   (error "missing style-warning for ~S" ',form))
+		 `(handler-case
+		   (eval ',form)
+		   (style-warning (e)
+		    (error "bad style-warning for ~S: ~A" ',form e))))))
+  (frob t (lambda (x &optional y &key z) (list x y z)))
+  (frob nil (lambda (x &optional y z) (list x y z)))
+  (frob nil (lambda (x &key y z) (list x y z)))
+  (frob t (defgeneric #:foo (x &optional y &key z)))
+  (frob nil (defgeneric #:foo (x &optional y z)))
+  (frob nil (defgeneric #:foo (x &key y z)))
+  (frob t (defun #:foo (x) (flet ((foo (x &optional y &key z) (list x y z))) (foo x x :z x)))))
+
+;;; this was a bug in the LOGXOR type deriver.  The top form gave a
+;;; note, because the system failed to derive the fact that the return
+;;; from LOGXOR was small and negative, though the bottom one worked.
+(handler-bind ((sb-ext:compiler-note #'error))
+  (compile nil '(lambda ()
+		 (declare (optimize speed (safety 0)))
+		 (lambda (x y)
+		   (declare (type (integer 3 6) x)
+			    (type (integer -6 -3) y))
+		   (+ (logxor x y) most-positive-fixnum)))))
+(handler-bind ((sb-ext:compiler-note #'error))
+  (compile nil '(lambda ()
+		 (declare (optimize speed (safety 0)))
+		 (lambda (x y)
+		   (declare (type (integer 3 6) y)
+			    (type (integer -6 -3) x))
+		   (+ (logxor x y) most-positive-fixnum)))))
+
+;;; check that modular ash gives the right answer, to protect against
+;;; possible misunderstandings about the hardware shift instruction.
+(assert (zerop (funcall
+		(compile nil '(lambda (x y)
+			       (declare (optimize speed)
+			                (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)))))))))