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,15 +3141,17 @@ ...@@ -3141,15 +3141,17 @@
;;; ;;;
(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))
(complexp1 (numeric-type-complexp t1))
(complexp2 (numeric-type-complexp t2)))
(cond ((or (null complexp1) (null class1)) Nil) (cond ((or (null complexp1) (null class1)) Nil)
((member class1 '(integer rational)) 'T) ((member class1 '(integer rational)) 'T)
((and (eq class1 'float) (null complexp2)) Nil) ((and (eq class1 'float) (null complexp2)) Nil)
...@@ -3174,12 +3176,23 @@ ...@@ -3174,12 +3176,23 @@
((and (eq class1 'float) (member class2 '(integer rational))) ((and (eq class1 'float) (member class2 '(integer rational)))
Nil) Nil)
(t (t
(error (intl:gettext "Unexpected types: ~s ~s~%") type1 type2))))))) (error (intl:gettext "Unexpected types: ~s ~s~%") t1 t2))))))
(maybe-convert-to-numeric (type)
(if (member-type-p type)
(convert-member-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))))
;;; 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