From cea76a8f9a567404019c42eab4930e3ece9a893e Mon Sep 17 00:00:00 2001 From: dtc <dtc> Date: Mon, 5 Jan 1998 05:54:58 +0000 Subject: [PATCH] Enhancement of the arithmetic function derive type optimizers to better handle float zeros, by Raymond Toy and Douglas Crosher: * The arithmetic function derive type optimisers now accept intervals for which -0.0 and 0.0 are recognisably different. This will fix naturally into a proposal by Raymond Toy which is conditional upon :negative-zero-is-not-zero. Without this feature the functions {one,two}-arg-derive-type convert the type intervals appropriately before and after these optimisers so that the user visible type specifiers behave the same. * Update interval-range-info to recognise the difference between -0.0 and 0.0. This in turn helps fix the phase derive type optimizer. * Elfun-derive-type-simple now uses a type specifier to giving the applicable range rather then a function; updates to the various uses of this function. * The sqrt and log derive type optimizers have been re-written and now use elfun-derive-type-simple. * Remove the unused function numeric-real-union-type-p. * Extend the expt trnasform to transform powers of 1/2 to sqrt. --- compiler/float-tran.lisp | 156 ++++++++----------------- compiler/srctran.lisp | 241 ++++++++++++++++++++++++++++++++++----- 2 files changed, 264 insertions(+), 133 deletions(-) diff --git a/compiler/float-tran.lisp b/compiler/float-tran.lisp index 0ee63b13a..163465a19 100644 --- a/compiler/float-tran.lisp +++ b/compiler/float-tran.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/float-tran.lisp,v 1.58 1998/01/02 05:08:52 dtc Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/float-tran.lisp,v 1.59 1998/01/05 05:54:55 dtc Exp $") ;;; ;;; ********************************************************************** ;;; @@ -280,9 +280,11 @@ :high new-hi))))) ;;; (defoptimizer (scale-single-float derive-type) ((f ex)) - (two-arg-derive-type f ex #'scale-float-derive-type-aux #'scale-single-float)) + (two-arg-derive-type f ex #'scale-float-derive-type-aux + #'scale-single-float t)) (defoptimizer (scale-double-float derive-type) ((f ex)) - (two-arg-derive-type f ex #'scale-float-derive-type-aux #'scale-double-float)) + (two-arg-derive-type f ex #'scale-float-derive-type-aux + #'scale-double-float t)) ;;; toy@rtp.ericsson.se: ;;; @@ -593,10 +595,16 @@ ;;;; function, based on the domain of the input. ;;;; -;;; Handle these monotonic increasing functions whose domain is -;;; possibly part of the real line - -(defun elfun-derive-type-simple (arg fcn cond default-lo default-hi) +;;; ELFUN-DERIVE-TYPE-SIMPLE +;;; +;;; Handle monotonic increasing functions of a single variable whose +;;; domain is possibly part of the real line. ARG is the variable, +;;; FCN is the function, and CSPEC is a specifier that gives the +;;; (real) domain of the function. If ARG is not a subtype of CSPEC, +;;; then the function is assumed to return either a float or a complex +;;; number. DEFAULT-LO and DEFAULT-HI are the lower and upper bounds +;;; if we can't compute the bounds using FCN. +(defun elfun-derive-type-simple (arg fcn cspec default-lo default-hi) (etypecase arg (numeric-type (cond ((eq (numeric-type-complexp arg) :complex) @@ -606,7 +614,7 @@ ((numeric-type-real-p arg) (let ((lo (numeric-type-low arg)) (hi (numeric-type-high arg))) - (if (funcall cond lo hi) + (if (csubtypep arg cspec) (let ((f-type (or (numeric-type-format arg) 'single-float))) (make-numeric-type :class 'float @@ -620,82 +628,40 @@ (float-or-complex-type arg default-lo default-hi)))))) (macrolet - ((frob (name cond def-lo-bnd def-hi-bnd) + ((frob (name cspec def-lo-bnd def-hi-bnd) (let ((num (gensym))) `(defoptimizer (,name derive-type) ((,num)) (one-arg-derive-type ,num #'(lambda (arg) (elfun-derive-type-simple arg #',name - ,cond + ,cspec ,def-lo-bnd ,def-hi-bnd)) #',name))))) ;; These functions are easy because they are defined for the whole ;; real line. - (frob exp (constantly t) + (frob exp (specifier-type 'real) 0 nil) - (frob sinh (constantly t) + (frob sinh (specifier-type 'real) nil nil) - (frob tanh (constantly t) + (frob tanh (specifier-type 'real) -1 1) - (frob asinh (constantly t) + (frob asinh (specifier-type 'real) nil nil) ;; These functions are only defined for part of the real line. The - ;; condition selects the desired part of the line. The default - ;; return value of (OR FLOAT (COMPLEX FLOAT)) is ok as the default. - (frob asin #'(lambda (lo hi) - (and lo hi - (>= (bound-value lo) -1) - (<= (bound-value hi) 1))) + ;; condition selects the desired part of the line. + (frob asin (specifier-type '(real -1d0 1d0)) #.(- (/ pi 2)) #.(/ pi 2)) - (frob acosh #'(lambda (lo hi) - (declare (ignore hi)) - (and lo (>= (bound-value lo) 1))) + (frob acosh (specifier-type '(real 1d0)) nil nil) - (frob atanh #'(lambda (lo hi) - (and lo hi - (>= (bound-value lo) -1) - (<= (bound-value hi) 1))) - -1 1)) - - -;;; Note must assume that a type including 0.0 may also include -0.0 -;;; and thus the result may be complex. -;;; -(defun sqrt-derive-type-aux (arg) - (etypecase arg - (numeric-type - (cond ((eq (numeric-type-complexp arg) :complex) - (make-numeric-type :class (numeric-type-class arg) - :format (numeric-type-format arg) - :complexp :complex)) - ((numeric-type-real-p arg) - (let* ((lo (numeric-type-low arg)) - (lo-val (and lo (bound-value lo))) - (hi (numeric-type-high arg))) - (if (typecase lo-val - (rational - (>= lo-val 0)) - (float - (if (consp lo) - (>= lo-val 0) - (> lo-val 0)))) - (let ((f-type (or (numeric-type-format arg) 'single-float))) - (make-numeric-type - :class 'float - :format f-type - :low (cond ((> lo-val 0) (bound-func #'sqrt lo)) - ((consp lo) (list (coerce 0 f-type))) - (t (coerce 0 f-type))) - :high (bound-func #'sqrt hi))) - (float-or-complex-type arg 0)))) - (t - (float-or-complex-type arg 0)))))) -;;; -(defoptimizer (sqrt derive-type) ((num)) - (one-arg-derive-type num #'sqrt-derive-type-aux #'sqrt)) - + (frob atanh (specifier-type '(real -1d0 1d0)) + -1 1) + (frob sqrt (specifier-type + #-negative-zero-is-not-zero '(or (member 0f0 0d0) (real (0d0))) + #+negative-zero-is-not-zero '(real 0d0)) + 0 nil)) + ;;; Acos is monotonic decreasing, so we need to swap the function ;;; values at the lower and upper bounds of the input domain. @@ -741,7 +707,7 @@ ;;; Handle the case when x >= 1 (defun interval-expt-> (x y) - (case (c::interval-range-info y) + (case (c::interval-range-info y 0d0) ('+ ;; Y is positive and log X >= 0. The range of exp(y * log(x)) is ;; obviously non-negative. We just have to be careful for @@ -769,7 +735,7 @@ ;;; Handle the case when x <= 1 (defun interval-expt-< (x y) - (case (c::interval-range-info x 0) + (case (c::interval-range-info x 0d0) ('+ ;; The case of 0 <= x <= 1 is easy (case (c::interval-range-info y) @@ -874,7 +840,7 @@ (integer ;; Positive rational to an integer power is always a rational (specifier-type `(rational ,(or (interval-low bnd) '*) - ,(or (interval-high bnd) '*)))) + ,(or (interval-high bnd) '*)))) (rational ;; Positive rational to rational power is either a rational ;; or a single-float. @@ -964,33 +930,13 @@ ;;; Note must assume that a type including 0.0 may also include -0.0 ;;; and thus the result may be complex -infinity + i*pi. ;;; -(defun log-derive-type-aux-1 (arg) - (etypecase arg - (numeric-type - (cond ((eq (numeric-type-complexp arg) :complex) - (make-numeric-type :class (numeric-type-class arg) - :format (numeric-type-format arg) - :complexp :complex)) - ((numeric-type-real-p arg) - (let* ((lo (numeric-type-low arg)) - (lo-val (and lo (bound-value lo))) - (hi (numeric-type-high arg))) - (if (typecase lo-val - (rational - (>= lo-val 0)) - (float - (if (consp lo) - (>= lo-val 0) - (> lo-val 0)))) - (let ((f-type (or (numeric-type-format arg) 'single-float))) - (make-numeric-type - :class 'float - :format f-type - :low (and (> lo-val 0) (bound-func #'log lo)) - :high (bound-func #'log hi))) - (float-or-complex-type arg)))) - (t - (float-or-complex-type arg)))))) +(defun log-derive-type-aux-1 (x) + (elfun-derive-type-simple + x #'log + (specifier-type + #-negative-zero-is-not-zero '(or (member 0f0 0d0) (real (0d0))) + #+negative-zero-is-not-zero '(real 0d0)) + nil nil)) (defun log-derive-type-aux-2 (x y same-arg) (let ((log-x (log-derive-type-aux-1 x)) @@ -1014,7 +960,7 @@ (defun atan-derive-type-aux-1 (y) (elfun-derive-type-simple - y #'atan (constantly t) #.(- (/ pi 2)) #.(/ pi 2))) + y #'atan (specifier-type 'real) #.(- (/ pi 2)) #.(/ pi 2))) (defun atan-derive-type-aux-2 (y x same-arg) (declare (ignore same-arg)) @@ -1034,28 +980,26 @@ (float-or-complex-type (numeric-contagion x y))))) (defoptimizer (atan derive-type) ((y &optional x)) - (cond ((null x) - (one-arg-derive-type y #'atan-derive-type-aux-1 #'atan)) - (t - (two-arg-derive-type y x #'atan-derive-type-aux-2 #'atan)))) + (if x + (two-arg-derive-type y x #'atan-derive-type-aux-2 #'atan) + (one-arg-derive-type y #'atan-derive-type-aux-1 #'atan))) (defun cosh-derive-type-aux (x) + ;; We note that cosh x = cosh |x| for all real x. (elfun-derive-type-simple (if (numeric-type-real-p x) (abs-derive-type-aux x) x) - #'cosh (constantly t) 0 nil)) + #'cosh (specifier-type 'real) 0 nil)) (defoptimizer (cosh derive-type) ((num)) (one-arg-derive-type num #'cosh-derive-type-aux #'cosh)) (defun phase-derive-type-aux (type) - ;; Warning: This optimizer doesn't yet handle the case of -0.0. - ;; It returns 0 for this case instead of pi. Need to fix this. (cond ((numeric-type-real-p type) - (case (interval-range-info (numeric-type->interval type)) + (case (interval-range-info (numeric-type->interval type) 0.0) ('+ ;; The number is positive, so the phase is 0. (make-numeric-type :class 'float @@ -1256,7 +1200,7 @@ ;; Divide a complex by a float (deftransform / ((w z) ((complex ,type) ,type) *) '(complex (/ (realpart w) z) (/ (imagpart w) z))) - ;; Conjugate of a float or complex number + ;; Conjugate of complex number (deftransform conjugate ((z) ((complex ,type)) *) '(complex (realpart z) (- (imagpart z)))) ;; Cis. diff --git a/compiler/srctran.lisp b/compiler/srctran.lisp index ef931bfb3..aaa53c2f8 100644 --- a/compiler/srctran.lisp +++ b/compiler/srctran.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/srctran.lisp,v 1.68 1997/12/21 00:14:51 dtc Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/srctran.lisp,v 1.69 1998/01/05 05:54:58 dtc Exp $") ;;; ;;; ********************************************************************** ;;; @@ -384,14 +384,18 @@ ;;; (defun interval-range-info (x &optional (point 0)) (declare (type interval x)) - (let ((lo (interval-low x)) - (hi (interval-high x))) - (cond ((and lo (>= (bound-value lo) point)) - '+) - ((and hi (<= (bound-value hi) point)) - '-) - (t - nil)))) + (labels ((signed->= (x y) + (if (and (zerop x) (zerop y) (floatp x) (floatp y)) + (>= (float-sign x) (float-sign y)) + (>= x y)))) + (let ((lo (interval-low x)) + (hi (interval-high x))) + (cond ((and lo (signed->= (bound-value lo) point)) + '+) + ((and hi (signed->= point (bound-value hi))) + '-) + (t + nil))))) ;;; INTERVAL-BOUNDED-P ;;; @@ -833,6 +837,149 @@ nil new-args)))) +;;; Convert from the standard type convention for which -0.0 and 0.0 +;;; and equal to an intermediate convention for which they are +;;; considered different which is more natural for some of the +;;; optimisers. +;;; +#-negative-zero-is-not-zero +(defun convert-numeric-type (type) + (declare (type numeric-type type)) + ;;; Only convert real float interval delimiters types. + (if (eq (numeric-type-complexp type) :real) + (let* ((lo (numeric-type-low type)) + (lo-val (bound-value lo)) + (lo-float-zero-p (and lo (floatp lo-val) (= lo-val 0.0))) + (hi (numeric-type-high type)) + (hi-val (bound-value hi)) + (hi-float-zero-p (and hi (floatp hi-val) (= hi-val 0.0)))) + (if (or lo-float-zero-p hi-float-zero-p) + (make-numeric-type + :class (numeric-type-class type) + :format (numeric-type-format type) + :complexp :real + :low (if lo-float-zero-p + (if (consp lo) + (list (float 0.0 lo-val)) + (float -0.0 lo-val)) + lo) + :high (if hi-float-zero-p + (if (consp hi) + (list (float -0.0 hi-val)) + (float 0.0 hi-val)) + hi)) + type)) + ;; Not real float. + type)) + +;;; Convert from the standard type convention for which -0.0 and 0.0 +;;; and equal to an intermediate convention for which they are +;;; considered different which is more natural for some of the +;;; optimisers. +;;; +#-negative-zero-is-not-zero +(defun convert-back-numeric-type (type) + (declare (type numeric-type type)) + ;;; Only convert real float interval delimiters types. + (if (eq (numeric-type-complexp type) :real) + (let* ((lo (numeric-type-low type)) + (lo-val (bound-value lo)) + (lo-float-zero-p + (and lo (floatp lo-val) (= lo-val 0.0) + (float-sign lo-val))) + (hi (numeric-type-high type)) + (hi-val (bound-value hi)) + (hi-float-zero-p + (and hi (floatp hi-val) (= hi-val 0.0) + (float-sign hi-val)))) + (cond + ;; (float +0.0 +0.0) => (member 0.0) + ;; (float -0.0 -0.0) => (member -0.0) + ((and lo-float-zero-p hi-float-zero-p) + ;; Shouldn't have exclusive bounds here. + (assert (and (not (consp lo)) (not (consp hi)))) + (if (= lo-float-zero-p hi-float-zero-p) + ;; (float +0.0 +0.0) => (member 0.0) + ;; (float -0.0 -0.0) => (member -0.0) + (specifier-type `(member ,lo-val)) + ;; (float -0.0 +0.0) => (float 0.0 0.0) + ;; (float +0.0 -0.0) => (float 0.0 0.0) + (make-numeric-type :class (numeric-type-class type) + :format (numeric-type-format type) + :complexp :real + :low hi-val + :high hi-val))) + (lo-float-zero-p + (cond + ;; (float -0.0 x) => (float 0.0 x) + ((and (not (consp lo)) (minusp lo-float-zero-p)) + (make-numeric-type :class (numeric-type-class type) + :format (numeric-type-format type) + :complexp :real + :low (float 0.0 lo-val) + :high hi)) + ;; (float (+0.0) x) => (float (0.0) x) + ((and (consp lo) (plusp lo-float-zero-p)) + (make-numeric-type :class (numeric-type-class type) + :format (numeric-type-format type) + :complexp :real + :low (list (float 0.0 lo-val)) + :high hi)) + (t + ;; (float +0.0 x) => (or (member 0.0) (float (0.0) x)) + ;; (float (-0.0) x) => (or (member 0.0) (float (0.0) x)) + (list (specifier-type `(member ,(float 0.0 lo-val))) + (make-numeric-type :class (numeric-type-class type) + :format (numeric-type-format type) + :complexp :real + :low (list (float 0.0 lo-val)) + :high hi))))) + (hi-float-zero-p + (cond + ;; (float x +0.0) => (float x 0.0) + ((and (not (consp hi)) (plusp hi-float-zero-p)) + (make-numeric-type :class (numeric-type-class type) + :format (numeric-type-format type) + :complexp :real + :low lo + :high (float 0.0 hi-val))) + ;; (float x (-0.0)) => (float x (0.0)) + ((and (consp hi) (minusp hi-float-zero-p)) + (make-numeric-type :class (numeric-type-class type) + :format (numeric-type-format type) + :complexp :real + :low lo + :high (list (float 0.0 hi-val)))) + (t + ;; (float x (+0.0)) => (or (member -0.0) (float x (0.0))) + ;; (float x -0.0) => (or (member -0.0) (float x (0.0))) + (list (specifier-type `(member ,(float -0.0 hi-val))) + (make-numeric-type :class (numeric-type-class type) + :format (numeric-type-format type) + :complexp :real + :low lo + :high (list (float 0.0 hi-val))))))) + (t + type))) + ;; Not real float. + type)) + +;;; Convert back a possible list of numeric types. +;;; +#-negative-zero-is-not-zero +(defun convert-back-numeric-type-list (type-list) + (declare (type (or list numeric-type) type-list)) + (cond ((listp type-list) + (collect ((results)) + (dolist (type type-list) + (results (if (numeric-type-p type) + (convert-back-numeric-type type) + type))) + (results))) + ((numeric-type-p type-list) + (convert-back-numeric-type type-list)) + (t + type-list))) ;;; ONE-ARG-DERIVE-TYPE ;;; @@ -848,7 +995,7 @@ ;;; For the case of member types, we call FCN on the element of the ;;; member type to get the resulting member type result. ;;; -(defun one-arg-derive-type (arg derive-fcn fcn) +(defun one-arg-derive-type (arg derive-fcn fcn &optional (convert-type t)) (let ((arg-list (prepare-arg-for-derive-type (continuation-type arg)))) (when arg-list (flet ((deriver (x) @@ -860,6 +1007,12 @@ `(member ,(funcall fcn (first (member-type-members x))))))) (numeric-type + #-negative-zero-is-not-zero + (if convert-type + (convert-back-numeric-type-list + (funcall derive-fcn (convert-numeric-type x))) + (funcall derive-fcn x)) + #+negative-zero-is-not-zero (funcall derive-fcn x)) (t *universal-type*)))) @@ -879,7 +1032,8 @@ ;;; deriving the type of things like (* x x), which should always be ;;; positive. If we didn't do this, we wouldn't be able to tell. ;;; -(defun two-arg-derive-type (arg1 arg2 derive-fcn fcn) +(defun two-arg-derive-type (arg1 arg2 derive-fcn fcn + &optional (convert-type t)) (labels ((convert-member-type (arg) (let* ((val (first (member-type-members arg))) (val-type (type-of val))) @@ -887,6 +1041,41 @@ 'integer val-type) ,val ,val)))) + ;; + #-negative-zero-is-not-zero + (deriver (x y same-arg) + (cond ((and (member-type-p x) (member-type-p y)) + (let* ((x (first (member-type-members x))) + (y (first (member-type-members y))) + (result (with-float-traps-masked + (:underflow :overflow :divide-by-zero) + (funcall fcn x y)))) + (if result + (specifier-type `(member ,result))))) + ((and (member-type-p x) (numeric-type-p y)) + (let* ((x (convert-member-type x)) + (y (if convert-type (convert-numeric-type y) y)) + (result (funcall derive-fcn x y same-arg))) + (if convert-type + (convert-back-numeric-type-list result) + result))) + ((and (numeric-type-p x) (member-type-p y)) + (let* ((x (if convert-type (convert-numeric-type x) x)) + (y (convert-member-type y)) + (result (funcall derive-fcn x y same-arg))) + (if convert-type + (convert-back-numeric-type-list result) + result))) + ((and (numeric-type-p x) (numeric-type-p y)) + (let* ((x (if convert-type (convert-numeric-type x) x)) + (y (if convert-type (convert-numeric-type y) y)) + (result (funcall derive-fcn x y same-arg))) + (if convert-type + (convert-back-numeric-type-list result) + result))) + (t + *universal-type*))) + #+negative-zero-is-not-zero (deriver (x y same-arg) (cond ((and (member-type-p x) (member-type-p y)) (let* ((x (first (member-type-members x))) @@ -1260,16 +1449,6 @@ #+propagate-float-type (progn -;;; Check to see that the type is either a real numeric-type or is a -;;; union of real numeric-types. -(defun numeric-real-union-type-p (type) - (cond ((csubtypep type (specifier-type 'real)) - t) - ((union-type-p type) - (every #'(lambda (x) - (csubtypep x (specifier-type 'real))) - (union-type-types type))))) - (defun rem-result-type (number-type divisor-type) ;; Figure out what the remainder type is. The remainder is an ;; integer if both args are integers; a rational if both args are @@ -1379,8 +1558,10 @@ (make-values-type :required (list - (two-arg-derive-type number divisor #'truncate-derive-type-quot-aux #'truncate) - (two-arg-derive-type number divisor #'truncate-derive-type-rem-aux #'rem)))) + (two-arg-derive-type number divisor + #'truncate-derive-type-quot-aux #'truncate) + (two-arg-derive-type number divisor + #'truncate-derive-type-rem-aux #'rem)))) (defun ftruncate-derive-type-quot (number-type divisor-type) ;; The bounds are the same as for truncate. However, the first @@ -1404,8 +1585,10 @@ (make-values-type :required (list - (two-arg-derive-type number divisor #'ftruncate-derive-type-quot-aux #'ftruncate) - (two-arg-derive-type number divisor #'truncate-derive-type-rem-aux #'rem)))) + (two-arg-derive-type number divisor + #'ftruncate-derive-type-quot-aux #'ftruncate) + (two-arg-derive-type number divisor + #'truncate-derive-type-rem-aux #'rem)))) (defun %unary-truncate-derive-type-aux (number) @@ -2550,9 +2733,11 @@ (give-up)) (if (minusp val) minus-result result))))) -;;; Fold (expt x n) into multiplications for small integral values of N. +;;; Fold (expt x n) into multiplications for small integral values of +;;; N; convert (expt x 1/2) to sqrt. +;;; (deftransform expt ((x y) (t (constant-argument real)) *) - "recode as multiplication" + "recode as multiplication or sqrt" (let ((val (continuation-value y))) ;; If Y would cause the result to be promoted to the same type as ;; Y, we give up. If not, then the result will be the same type @@ -2565,6 +2750,8 @@ ((= val -2) '(/ (* x x))) ((= val 3) '(* x x x)) ((= val -3) '(/ (* x x x))) + ((= val 1/2) '(sqrt x)) + ((= val -1/2) '(/ (sqrt x))) (t (give-up))))) (dolist (name '(ash /)) -- GitLab