Commit f36a31aa authored by Raymond Toy's avatar Raymond Toy
Browse files

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.
parent bb56dbb6
...@@ -3141,45 +3141,58 @@ ...@@ -3141,45 +3141,58 @@
;;; ;;;
(defun not-more-contagious (x y) (defun not-more-contagious (x y)
(declare (type continuation x y)) (declare (type continuation x y))
(let ((type1 (continuation-type x)) (let ((x-type (continuation-type x))
(type2 (continuation-type y))) (y-type (continuation-type y)))
(if (and (numeric-type-p type1) (numeric-type-p type2)) (flet
(let ((class1 (numeric-type-class type1)) ((not-more-contagious-1 (t1 t2)
(class2 (numeric-type-class type2)) (if (and (numeric-type-p t1) (numeric-type-p t2))
(format1 (numeric-type-format type1)) (let ((class1 (numeric-type-class t1))
(format2 (numeric-type-format type2)) (class2 (numeric-type-class t2))
(complexp1 (numeric-type-complexp type1)) (format1 (numeric-type-format t1))
(complexp2 (numeric-type-complexp type2))) (format2 (numeric-type-format t2))
(cond ((or (null complexp1) (null class1)) Nil) (complexp1 (numeric-type-complexp t1))
((member class1 '(integer rational)) 'T) (complexp2 (numeric-type-complexp t2)))
((and (eq class1 'float) (null complexp2)) Nil) (cond ((or (null complexp1) (null class1)) Nil)
((and (eq class1 'float) (null class2)) Nil) ((member class1 '(integer rational)) 'T)
((and (eq class1 'float) (eq class2 'float)) ((and (eq class1 'float) (null complexp2)) Nil)
(and (ecase complexp2 ((and (eq class1 'float) (null class2)) Nil)
(:real (eq complexp1 :real)) ((and (eq class1 'float) (eq class2 'float))
(:complex 'T)) (and (ecase complexp2
(ecase format2 (:real (eq complexp1 :real))
((nil short-float single-float) (:complex 'T))
(member format1 '(short-float single-float))) (ecase format2
#-double-double ((nil short-float single-float)
((double-float long-float) 'T) (member format1 '(short-float single-float)))
#+double-double #-double-double
(double-float ((double-float long-float) 'T)
(member format1 '(short-float single-float #+double-double
double-float))) (double-float
#+long-float (member format1 '(short-float single-float
(long-float 'T) double-float)))
#+double-double #+long-float
(double-double-float 't)))) (long-float 'T)
((and (eq class1 'float) (member class2 '(integer rational))) #+double-double
Nil) (double-double-float 't))))
(t ((and (eq class1 'float) (member class2 '(integer rational)))
(error (intl:gettext "Unexpected types: ~s ~s~%") type1 type2))))))) 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). ;;; Fold (- x 0).
;;; ;;;
;;; If y is not constant, not zerop, or is contagious, or a negative ;;; 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) (deftransform - ((x y) (t (constant-argument number)) * :when :both)
"fold zero arg" "fold zero arg"
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment