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@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