[cmucl-commit] [git] CMU Common Lisp branch master updated. snapshot-2013-07-1-gf36a31a

[Raymond Toy]

This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "CMU Common Lisp".

The branch, master has been updated
       via  f36a31aaf95b60e2cc210648d951b41d3112a73a (commit)
      from  bb56dbb6572939222d731530c3045b4a87ee7f51 (commit)

Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.

- Log -----------------------------------------------------------------
commit f36a31aaf95b60e2cc210648d951b41d3112a73a
Author: Raymond Toy <toy.raymond at gmail.com>
Date:   Fri Jul 5 06:56:29 2013 -0700

    Make NOT-MORE-CONTAGIOUS support member and union types.
    
    This change allow cmucl to fold identity operations as in
    
    (defun foo (x)
      (declare (float x))
      (* x 1))
    
    Previously, cmucl wouldn't change (* x 1) to just x. because the
    declaration of x is represented internally as a union type.

diff --git a/src/compiler/srctran.lisp b/src/compiler/srctran.lisp
index 7888eba..c12251c 100644
--- a/src/compiler/srctran.lisp
+++ b/src/compiler/srctran.lisp
@@ -3141,45 +3141,58 @@
 ;;;
 (defun not-more-contagious (x y)
   (declare (type continuation x y))
-  (let ((type1 (continuation-type x))
-	(type2 (continuation-type y)))
-    (if (and (numeric-type-p type1) (numeric-type-p type2))
-	(let ((class1 (numeric-type-class type1))
-	      (class2 (numeric-type-class type2))
-	      (format1 (numeric-type-format type1))
-	      (format2 (numeric-type-format type2))
-	      (complexp1 (numeric-type-complexp type1))
-	      (complexp2 (numeric-type-complexp type2)))
-	  (cond ((or (null complexp1) (null class1)) Nil)
-		((member class1 '(integer rational)) 'T)
-		((and (eq class1 'float) (null complexp2)) Nil)
-		((and (eq class1 'float) (null class2)) Nil)
-		((and (eq class1 'float) (eq class2 'float))
-		 (and (ecase complexp2
-			(:real (eq complexp1 :real))
-			(:complex 'T))
-		      (ecase format2
-			((nil short-float single-float)
-			 (member format1 '(short-float single-float)))
-			#-double-double
-			((double-float long-float) 'T)
-			#+double-double
-			(double-float
-			 (member format1 '(short-float single-float
-					   double-float)))
-			#+long-float
-			(long-float 'T)
-			#+double-double
-			(double-double-float 't))))
-		((and (eq class1 'float) (member class2 '(integer rational)))
-		 Nil)
-		(t
-		 (error (intl:gettext "Unexpected types: ~s ~s~%") type1 type2)))))))
+  (let ((x-type (continuation-type x))
+	(y-type (continuation-type y)))
+    (flet
+	((not-more-contagious-1 (t1 t2)
+	   (if (and (numeric-type-p t1) (numeric-type-p t2))
+	       (let ((class1 (numeric-type-class t1))
+		     (class2 (numeric-type-class t2))
+		     (format1 (numeric-type-format t1))
+		     (format2 (numeric-type-format t2))
+		     (complexp1 (numeric-type-complexp t1))
+		     (complexp2 (numeric-type-complexp t2)))
+		 (cond ((or (null complexp1) (null class1)) Nil)
+		       ((member class1 '(integer rational)) 'T)
+		       ((and (eq class1 'float) (null complexp2)) Nil)
+		       ((and (eq class1 'float) (null class2)) Nil)
+		       ((and (eq class1 'float) (eq class2 'float))
+			(and (ecase complexp2
+			       (:real (eq complexp1 :real))
+			       (:complex 'T))
+			     (ecase format2
+			       ((nil short-float single-float)
+				(member format1 '(short-float single-float)))
+			       #-double-double
+			       ((double-float long-float) 'T)
+			       #+double-double
+			       (double-float
+				(member format1 '(short-float single-float
+						  double-float)))
+			       #+long-float
+			       (long-float 'T)
+			       #+double-double
+			       (double-double-float 't))))
+		       ((and (eq class1 'float) (member class2 '(integer rational)))
+			Nil)
+		       (t
+			(error (intl:gettext "Unexpected types: ~s ~s~%") t1 t2))))))
+	 (maybe-convert-to-numeric (type)
+	   (if (member-type-p type)
+	       (convert-member-type type)
+	       type)))
+      (dolist (x (prepare-arg-for-derive-type x-type))
+	(dolist (y (prepare-arg-for-derive-type y-type))
+	  (unless (not-more-contagious-1
+		   (maybe-convert-to-numeric x)
+		   (maybe-convert-to-numeric y))
+	    (return-from not-more-contagious nil))))
+      t)))
 
 ;;; Fold (- x 0).
 ;;;
 ;;;    If y is not constant, not zerop, or is contagious, or a negative
-;;; float -0.0 then give up because (- -0.0 -0.0) is 0.0, not -0.0.
+;;; float -0.0 then give up because (- -0.0 0.0) is 0.0, not -0.0.
 ;;;
 (deftransform - ((x y) (t (constant-argument number)) * :when :both)
   "fold zero arg"

-----------------------------------------------------------------------

Summary of changes:
 src/compiler/srctran.lisp |   83 ++++++++++++++++++++++++++-------------------
 1 file changed, 48 insertions(+), 35 deletions(-)


hooks/post-receive
-- 
CMU Common Lisp