diff --git a/compiler/srctran.lisp b/compiler/srctran.lisp index 0ad53e07c326ad4febcfd95da7b45fe568955956..72cbb685a2aa4580c65067bec05de8de20cc0f47 100644 --- a/compiler/srctran.lisp +++ b/compiler/srctran.lisp @@ -7,7 +7,7 @@ ;;; Scott Fahlman or slisp-group@cs.cmu.edu. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/srctran.lisp,v 1.34 1992/02/02 23:05:17 ram Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/srctran.lisp,v 1.35 1992/02/03 22:15:22 ram Exp $") ;;; ;;; ********************************************************************** ;;; @@ -958,8 +958,7 @@ (setf result (tub32 (if result - `(+ ,(tub32 next-factor) - ,result) + `(+ ,result ,(tub32 next-factor)) next-factor))))) (declare (inline add)) (dotimes (bitpos 32) @@ -1079,11 +1078,16 @@ result)) -;;; This is restricted to rationals, because (- 0 0.0) is 0.0, not -0.0. +;;; These are restricted to rationals, because (- 0 0.0) is 0.0, not -0.0, and +;;; (* 0 -4.0) is -0.0. ;;; -(deftransform - ((x y) ((member 0) rational)) +(deftransform - ((x y) ((constant-argument (member 0)) rational)) "convert (- 0 x) to negate" '(%negate y)) +;;; +(deftransform * ((x y) (rational (constant-argument (member 0)))) + "convert (* x 0) to 0." + 0) ;;; NOT-MORE-CONTAGIOUS -- Interface @@ -1099,32 +1103,22 @@ (values (type= (numeric-contagion x y) (numeric-contagion y y))))) -;;; OK-ZERO-OR-LOSE -- Interface -;;; -;;; If y is not constant, not zerop, or is -0.0, or is contagious, then give -;;; up. We throw out negative zero because it is likely to cause sign changes, -;;; and is not likely to appear in places where we actually case about -;;; optimizing identities. -;;; -(defun ok-zero-or-lose (x y) - (unless (constant-continuation-p y) (give-up)) - (let ((val (continuation-value y))) - (unless (and (zerop val) - (not (and (floatp val) (minusp (float-sign val)))) - (not-more-contagious y x)) - (give-up)))) - ;;; Fold (OP x 0). ;;; +;;; If y is not constant, not zerop, or is contagious, then give up. +;;; (loop for (name result) in - '((* 0) - (+ x) + '((+ x) (- x) (expt 1)) do - (deftransform name ((x y) '* '* :eval-name t) + (deftransform name ((x y) '(t (constant-argument t)) '* :eval-name t) "fold zero arg" - (ok-zero-or-lose x y) + (let ((val (continuation-value y))) + (unless (and (zerop val) + (not (and (floatp val) (minusp (float-sign val)))) + (not-more-contagious y x)) + (give-up))) result)) ;;; Fold (OP x +/-1) @@ -1133,9 +1127,8 @@ '((* x (%negate x)) (/ x (%negate x)) (expt x (/ 1 x))) do - (deftransform name ((x y) '* '* :eval-name t) + (deftransform name ((x y) '(t (constant-argument t)) '* :eval-name t) "fold identity operations" - (unless (constant-continuation-p y) (give-up)) (let ((val (continuation-value y))) (unless (and (= (abs val) 1) (not-more-contagious y x))