From 3fe8030ece2b56257f6b9b2b5a3aae25ed42e7c6 Mon Sep 17 00:00:00 2001
From: dtc <dtc>
Date: Mon, 5 Jan 1998 22:35:04 +0000
Subject: [PATCH] Change to the handling of floating point zeros within numeric
 type specifiers by Raymond Toy. With these changes -0.0 and 0.0 and
 considered separate on the float type intervals which is more natural for
 many arithmetic function derive type optimizers.  These changes are dependent
 upon the :negative-zero-is-not-zero feature.

---
 code/pred.lisp          | 34 +++++++++++++++++++++++++++++++++-
 code/type.lisp          | 35 ++++++++++++++++++++++++++++++++++-
 compiler/typetran.lisp  | 22 +++++++++++++++++++++-
 compiler/x86/float.lisp | 20 +++++++++++++++++++-
 4 files changed, 107 insertions(+), 4 deletions(-)

diff --git a/code/pred.lisp b/code/pred.lisp
index d04096430..1da31992f 100644
--- a/code/pred.lisp
+++ b/code/pred.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/code/pred.lisp,v 1.43 1997/11/29 20:13:11 dtc Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/pred.lisp,v 1.44 1998/01/05 22:34:54 dtc Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -209,6 +209,7 @@
 		 (long-float (typep num 'long-float))
 		 ((nil) (floatp num))))
 	      ((nil) t)))
+	  #-negative-zero-is-not-zero
 	  (flet ((bound-test (val)
 		   (let ((low (numeric-type-low type))
 			 (high (numeric-type-high type)))
@@ -218,6 +219,37 @@
 			  (cond ((null high) t)
 				((listp high) (< val (car high)))
 				(t (<= val high)))))))
+	    (ecase (numeric-type-complexp type)
+	      ((nil) t)
+	      (:complex
+	       (and (complexp object)
+		    (bound-test (realpart object))
+		    (bound-test (imagpart object))))
+	      (:real
+	       (and (not (complexp object))
+		    (bound-test object)))))
+	  #+negative-zero-is-not-zero
+	  (labels ((signed-> (x y)
+		     (if (and (zerop x) (zerop y) (floatp x) (floatp y))
+			 (> (float-sign x) (float-sign y))
+			 (> x y)))
+		   (signed->= (x y)
+		     (if (and (zerop x) (zerop y) (floatp x) (floatp y))
+			 (>= (float-sign x) (float-sign y))
+			 (>= x y)))
+		   (bound-test (val)
+		     (let ((low (numeric-type-low type))
+			   (high (numeric-type-high type)))
+		       (and (cond ((null low) t)
+				  ((listp low)
+				   (signed-> val (car low)))
+				  (t
+				   (signed->= val low)))
+			    (cond ((null high) t)
+				  ((listp high)
+				   (signed-> (car high) val))
+				  (t
+				   (signed->= high val)))))))
 	    (ecase (numeric-type-complexp type)
 	      ((nil) t)
 	      (:complex
diff --git a/code/type.lisp b/code/type.lisp
index 1d6d512b9..851e409fc 100644
--- a/code/type.lisp
+++ b/code/type.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/code/type.lisp,v 1.23 1997/12/18 16:49:10 dtc Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/type.lisp,v 1.24 1998/01/05 22:34:56 dtc Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -1118,6 +1118,7 @@
 ;;;    This is for comparing bounds of the same kind, e.g. upper and upper.
 ;;; Use Numeric-Bound-Test* for different kinds of bounds.
 ;;;
+#-negative-zero-is-not-zero
 (defmacro numeric-bound-test (x y closed open)
   `(cond ((not ,y) t)
 	 ((not ,x) nil)
@@ -1130,6 +1131,24 @@
 	      (,open ,x (car ,y))
 	      (,closed ,x ,y)))))
 
+#+negative-zero-is-not-zero
+(defmacro numeric-bound-test-zero (op x y)
+  `(if (and (zerop ,x) (zerop ,y) (floatp ,x) (floatp ,y))
+       (,op (float-sign ,x) (float-sign ,y))
+       (,op ,x ,y)))
+
+#+negative-zero-is-not-zero
+(defmacro numeric-bound-test (x y closed open)
+  `(cond ((not ,y) t)
+	 ((not ,x) nil)
+	 ((consp ,x)
+	  (if (consp ,y)
+	      (numeric-bound-test-zero ,closed (car ,x) (car ,y))
+	      (numeric-bound-test-zero ,closed (car ,x) ,y)))
+	 (t
+	  (if (consp ,y)
+	      (numeric-bound-test-zero ,open ,x (car ,y))
+	      (numeric-bound-test-zero ,closed ,x ,y)))))
 
 ;;; Numeric-Bound-Test*  --  Internal
 ;;;
@@ -1140,6 +1159,7 @@
 ;;; -- an open inner bound is "greater" and also squeezes the interval, causing
 ;;;    us to use the Open test for those cases as well.
 ;;;
+#-negative-zero-is-not-zero
 (defmacro numeric-bound-test* (x y closed open)
   `(cond ((not ,y) t)
 	 ((not ,x) t)
@@ -1152,6 +1172,19 @@
 	      (,open ,x (car ,y))
 	      (,closed ,x ,y)))))
 
+#+negative-zero-is-not-zero
+(defmacro numeric-bound-test* (x y closed open)
+  `(cond ((not ,y) t)
+	 ((not ,x) t)
+	 ((consp ,x)
+	  (if (consp ,y)
+	      (numeric-bound-test-zero ,open (car ,x) (car ,y))
+	      (numeric-bound-test-zero ,open (car ,x) ,y)))
+	 (t
+	  (if (consp ,y)
+	      (numeric-bound-test-zero ,open ,x (car ,y))
+	      (numeric-bound-test-zero ,closed ,x ,y)))))
+
 
 ;;; Numeric-Bound-Max  --  Internal
 ;;;
diff --git a/compiler/typetran.lisp b/compiler/typetran.lisp
index db6899ee0..a5fa991ad 100644
--- a/compiler/typetran.lisp
+++ b/compiler/typetran.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/typetran.lisp,v 1.31 1997/11/15 04:38:57 dtc Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/typetran.lisp,v 1.32 1998/01/05 22:35:00 dtc Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -175,6 +175,7 @@
 ;;; specified by Type.  Base is the name of the base type, for declaration.  We
 ;;; make safety locally 0 to inhibit any checking of this assertion.
 ;;;
+#-negative-zero-is-not-zero
 (defun transform-numeric-bound-test (n-object type base)
   (declare (type numeric-type type))
   (let ((low (numeric-type-low type))
@@ -190,6 +191,25 @@
 		    `((< (the ,base ,n-object) ,(car high)))
 		    `((<= (the ,base ,n-object) ,high))))))))
 
+#+negative-zero-is-not-zero
+(defun transform-numeric-bound-test (n-object type base)
+  (declare (type numeric-type type))
+  (let ((low (numeric-type-low type))
+	(high (numeric-type-high type)))
+    `(locally
+       (declare (optimize (safety 0)))
+       (and ,@(when low
+		(if (consp low)
+		    `((kernel::numeric-bound-test-zero
+		       > (the ,base ,n-object) ,(car low)))
+		    `((kernel::numeric-bound-test-zero
+		       >= (the ,base ,n-object) ,low))))
+	    ,@(when high
+		(if (consp high)
+		    `((kernel::numeric-bound-test-zero
+		       < (the ,base ,n-object) ,(car high)))
+		    `((kernel::numeric-bound-test-zero
+		       <= (the ,base ,n-object) ,high))))))))
 
 ;;; Source-Transform-Numeric-Typep  --  Internal
 ;;;
diff --git a/compiler/x86/float.lisp b/compiler/x86/float.lisp
index c3b2b952c..d2d419339 100644
--- a/compiler/x86/float.lisp
+++ b/compiler/x86/float.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/x86/float.lisp,v 1.17 1997/11/30 22:53:51 dtc Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/x86/float.lisp,v 1.18 1998/01/05 22:35:04 dtc Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -1230,34 +1230,52 @@
 (define-vop (=0/single-float float-test)
   (:translate =)
   (:args (x :scs (single-reg)))
+  #-negative-zero-is-not-zero
   (:arg-types single-float (:constant (single-float 0f0 0f0)))
+  #+negative-zero-is-not-zero
+  (:arg-types single-float (:constant (single-float -0f0 0f0)))
   (:variant #x40))
 (define-vop (=0/double-float float-test)
   (:translate =)
   (:args (x :scs (double-reg)))
+  #-negative-zero-is-not-zero
   (:arg-types double-float (:constant (double-float 0d0 0d0)))
+  #+negative-zero-is-not-zero
+  (:arg-types double-float (:constant (double-float -0d0 0d0)))
   (:variant #x40))
 
 (define-vop (<0/single-float float-test)
   (:translate <)
   (:args (x :scs (single-reg)))
+  #-negative-zero-is-not-zero
   (:arg-types single-float (:constant (single-float 0f0 0f0)))
+  #+negative-zero-is-not-zero
+  (:arg-types single-float (:constant (single-float -0f0 0f0)))
   (:variant #x01))
 (define-vop (<0/double-float float-test)
   (:translate <)
   (:args (x :scs (double-reg)))
+  #-negative-zero-is-not-zero
   (:arg-types double-float (:constant (double-float 0d0 0d0)))
+  #+negative-zero-is-not-zero
+  (:arg-types double-float (:constant (double-float -0d0 0d0)))
   (:variant #x01))
 
 (define-vop (>0/single-float float-test)
   (:translate >)
   (:args (x :scs (single-reg)))
+  #-negative-zero-is-not-zero
   (:arg-types single-float (:constant (single-float 0f0 0f0)))
+  #+negative-zero-is-not-zero
+  (:arg-types single-float (:constant (single-float -0f0 0f0)))
   (:variant #x00))
 (define-vop (>0/double-float float-test)
   (:translate >)
   (:args (x :scs (double-reg)))
+  #-negative-zero-is-not-zero
   (:arg-types double-float (:constant (double-float 0d0 0d0)))
+  #+negative-zero-is-not-zero
+  (:arg-types double-float (:constant (double-float -0d0 0d0)))
   (:variant #x00))
 
 
-- 
GitLab