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 @@
;;;
(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)))
(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)
......@@ -3174,12 +3176,23 @@
((and (eq class1 'float) (member class2 '(integer rational)))
Nil)
(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)
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"
......
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