From af5e6fb56080510e43d21984a64a289da0281693 Mon Sep 17 00:00:00 2001
From: dtc <dtc>
Date: Tue, 29 Sep 1998 13:16:28 +0000
Subject: [PATCH] Change the domain argument of elfun-derive-type-simple from a
 numeric-type to a high and low bound for which negative and positive zero
 being distinct as for the :negative-zero-not-zero feature.  This fixes some
 problems that occurred when not compiled with the :negative-zero-not-zero
 feature.

---
 compiler/float-tran.lisp | 148 +++++++++++++++++++++++----------------
 1 file changed, 86 insertions(+), 62 deletions(-)

diff --git a/compiler/float-tran.lisp b/compiler/float-tran.lisp
index 5f9e4b5f9..476d88854 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.75 1998/09/20 15:17:34 dtc Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/float-tran.lisp,v 1.76 1998/09/29 13:16:28 dtc Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -556,26 +556,6 @@
   (and (numeric-type-p type)
        (eq (numeric-type-complexp type) :real)))
 
-
-;;; Functions to handle most cases of computing the bounds for a
-;;; function.
-;;;
-;;; NUM is a numeric type representing the argument to the
-;;; function.
-;;;
-;;; COND is an function that returns T when the number satisfies the
-;;; desired condition.  It should take two arguments LO and HI which
-;;; are the lower and upper bounds of the numeric-type.
-;;;
-;;; LIMIT-FUN is a function that returns the lower and upper
-;;; bounds.after applying the desired function. Also, the limit
-;;; function can return the preferred type of float, if
-;;; necessary. This feature is used by the float optimizer to
-;;; determine the desired result type.
-;;;
-;;; DEFAULT-TYPE is the specifier-type of the result if COND should
-;;; return NIL.
-
 ;;; Coerce a numeric type bound to the given type while handling
 ;;; exclusive bounds.
 (defun coerce-numeric-bound (bound type)
@@ -584,6 +564,17 @@
 	(list (coerce (car bound) type))
 	(coerce bound type))))
 
+)  ; end progn
+
+#+propagate-fun-type
+(progn
+
+;;;; Optimizers for elementary functions
+;;;;
+;;;; These optimizers compute the output range of the elementary
+;;;; function, based on the domain of the input.
+;;;;
+
 ;;; Compute a specifier like '(or float (complex float)), except float
 ;;; should be the right kind of float.  Allow bounds for the float
 ;;; part too.
@@ -598,15 +589,47 @@
     (specifier-type `(or (,float-type ,(or lo '*) ,(or hi '*))
 		         (complex ,float-type)))))
 
-)  ; end progn
-
-#+propagate-fun-type
-(progn
-;;;; Optimizers for elementary functions
-;;;;
-;;;; These optimizers compute the output range of the elementary
-;;;; function, based on the domain of the input.
-;;;;
+;;; Domain-Subtype
+;;;
+;;; Test if the numeric-type ARG is within in domain specified by
+;;; DOMAIN-LOW and DOMAIN-HIGH, consider negative and positive zero to
+;;; be distinct as for the :negative-zero-is-not-zero feature. With
+;;; the :negative-zero-is-not-zero feature this could be handled by
+;;; the numeric subtype code in type.lisp.
+;;;
+(defun domain-subtypep (arg domain-low domain-high)
+  (declare (type numeric-type arg)
+	   (type (or real null) domain-low domain-high))
+  (let* ((arg-lo (numeric-type-low arg))
+	 (arg-lo-val (bound-value arg-lo))
+	 (arg-hi (numeric-type-high arg))
+	 (arg-hi-val (bound-value arg-hi)))
+    ;; Check that the ARG bounds are correctly canonicalised.
+    (when (and arg-lo (floatp arg-lo-val) (zerop arg-lo-val) (consp arg-lo)
+	       (minusp (float-sign arg-lo-val)))
+      (compiler-note "Float zero bound ~s not correctly canonicalised?" arg-lo)
+      (setq arg-lo '(0l0) arg-lo-val 0l0))
+    (when (and arg-hi (zerop arg-hi-val) (floatp arg-hi-val) (consp arg-hi)
+	       (plusp (float-sign arg-hi-val)))
+      (compiler-note "Float zero bound ~s not correctly canonicalised?" arg-hi)
+      (setq arg-hi '(-0l0) arg-hi-val -0l0))
+    ;;
+    (and (or (null domain-low)
+	     (and arg-lo (>= arg-lo-val domain-low)
+		  (not (and (zerop domain-low) (floatp domain-low)
+			    (plusp (float-sign domain-low))
+			    (zerop arg-lo-val) (floatp arg-lo-val)
+			    (if (consp arg-lo)
+				(plusp (float-sign arg-lo-val))
+				(minusp (float-sign arg-lo-val)))))))
+	 (or (null domain-high)
+	     (and arg-hi (<= arg-hi-val domain-high)
+		  (not (and (zerop domain-high) (floatp domain-high)
+			    (minusp (float-sign domain-high))
+			    (zerop arg-hi-val) (floatp arg-hi-val)
+			    (if (consp arg-hi)
+				(minusp (float-sign arg-hi-val))
+				(plusp (float-sign arg-hi-val))))))))))
 
 ;;; Elfun-Derive-Type-Simple
 ;;; 
@@ -618,11 +641,17 @@
 ;;; intersection between ARG and DOMAIN, and then append a complex
 ;;; result, which occurs for the parts of ARG not in the DOMAIN.
 ;;;
-;;; DEFAULT-LO and DEFAULT-HI are the lower and upper bounds if we
+;;; Negative and positive zero are considered distinct within
+;;; DOMAIN-LOW and DOMAIN-HIGH, as for the :negative-zero-is-not-zero
+;;; feature.
+;;;
+;;; DEFAULT-LOW and DEFAULT-HIGH are the lower and upper bounds if we
 ;;; can't compute the bounds using FCN.
 ;;;
-(defun elfun-derive-type-simple (arg fcn domain default-lo default-hi
+(defun elfun-derive-type-simple (arg fcn domain-low domain-high
+				     default-low default-high
 				     &optional (increasingp t))
+  (declare (type (or null real) domain-low domain-high))
   (etypecase arg
     (numeric-type
      (cond ((eq (numeric-type-complexp arg) :complex)
@@ -638,18 +667,16 @@
 	    (multiple-value-bind (intersection difference)
 		(interval-intersection/difference
 		 (numeric-type->interval arg)
-		 (if (numeric-type-p domain)
-		     (numeric-type->interval domain)
-		     (make-interval)))
+		 (make-interval :low domain-low :high domain-high))
 	      (cond
 		(intersection
 		 ;; Process the intersection.
 		 (let* ((low (interval-low intersection))
 			(high (interval-high intersection))
 			(res-lo (or (bound-func fcn (if increasingp low high))
-				    default-lo))
+				    default-low))
 			(res-hi (or (bound-func fcn (if increasingp high low))
-				    default-hi))
+				    default-high))
 			;; Result specifier type.
 			(format (case (numeric-type-class arg)
 				  ((integer rational) 'single-float)
@@ -664,45 +691,48 @@
 		   ;; If the ARG is a subset of the domain, we don't
 		   ;; have to worry about the difference, because that
 		   ;; can't occur.
-		   (if (or (null difference) (csubtypep arg domain))
+		   (if (or (null difference)
+			   ;; Check if the arg is within the domain.
+			   (domain-subtypep arg domain-low domain-high))
 		       result-type
 		       (list result-type
 			     (specifier-type `(complex ,bound-type))))))
 		(t
 		 (float-or-complex-float-type arg)))))
 	   (t
-	    (float-or-complex-float-type arg default-lo default-hi))))))
+	    (float-or-complex-float-type arg default-low default-high))))))
 
 (macrolet
-    ((frob (name domain def-lo-bnd def-hi-bnd &key (increasingp t))
+    ((frob (name domain-low domain-high def-low-bnd def-high-bnd
+		 &key (increasingp t))
        (let ((num (gensym)))
 	 `(defoptimizer (,name derive-type) ((,num))
 	   (one-arg-derive-type
 	    ,num
 	    #'(lambda (arg)
 		(elfun-derive-type-simple arg #',name
-					  ,domain
-					  ,def-lo-bnd ,def-hi-bnd
+					  ,domain-low ,domain-high
+					  ,def-low-bnd ,def-high-bnd
 					  ,increasingp))
 	    #',name)))))
   ;; These functions are easy because they are defined for the whole
   ;; real line.
-  (frob exp (specifier-type 'real) 0 nil)
-  (frob sinh (specifier-type 'real) nil nil)
-  (frob tanh (specifier-type 'real) -1 1)
-  (frob asinh (specifier-type 'real) nil nil)
+  (frob exp nil nil 0 nil)
+  (frob sinh nil nil nil nil)
+  (frob tanh nil nil -1 1)
+  (frob asinh nil nil nil nil)
 
   ;; These functions are only defined for part of the real line.  The
   ;; condition selects the desired part of the line.  
-  (frob asin (specifier-type '(real -1d0 1d0)) (- (/ pi 2)) (/ pi 2))
+  (frob asin -1d0 1d0 (- (/ pi 2)) (/ pi 2))
   ;; Acos is monotonic decreasing, so we need to swap the function
   ;; values at the lower and upper bounds of the input domain.
-  (frob acos (specifier-type '(real -1d0 1d0)) 0 pi :increasingp nil)
-  (frob acosh (specifier-type '(real 1d0)) nil nil)
-  (frob atanh (specifier-type '(real -1d0 1d0))	-1 1)
-  (frob sqrt (specifier-type #-negative-zero-is-not-zero '(real 0d0)
-			     #+negative-zero-is-not-zero '(real -0d0))
-	0 nil))
+  (frob acos -1d0 1d0 0 pi :increasingp nil)
+  (frob acosh 1d0 nil nil nil)
+  (frob atanh -1d0 1d0 -1 1)
+  ;; Kahan says that (sqrt -0.0) is -0.0, so use a specifier that
+  ;; includes -0.0.
+  (frob sqrt -0d0 nil 0 nil))
  
 ;;; Compute bounds for (expt x y).  This should be easy since (expt x
 ;;; y) = (exp (* y (log x))).  However, computations done this way
@@ -940,12 +970,7 @@
 ;;; and thus the result may be complex -infinity + i*pi.
 ;;;
 (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))
+  (elfun-derive-type-simple x #'log 0d0 nil nil nil))
 
 (defun log-derive-type-aux-2 (x y same-arg)
   (let ((log-x (log-derive-type-aux-1 x))
@@ -968,8 +993,7 @@
 
 
 (defun atan-derive-type-aux-1 (y)
-  (elfun-derive-type-simple
-   y #'atan (specifier-type 'real) (- (/ pi 2)) (/ pi 2)))
+  (elfun-derive-type-simple y #'atan nil nil (- (/ pi 2)) (/ pi 2)))
 
 (defun atan-derive-type-aux-2 (y x same-arg)
   (declare (ignore same-arg))
@@ -1002,7 +1026,7 @@
    (if (numeric-type-real-p x)
        (abs-derive-type-aux x)
        x)
-   #'cosh (specifier-type 'real) 0 nil))
+   #'cosh nil nil 0 nil))
 
 (defoptimizer (cosh derive-type) ((num))
   (one-arg-derive-type num #'cosh-derive-type-aux #'cosh))
-- 
GitLab