From 323d722fd0b3ec0c0d914810537f615cd357aacf Mon Sep 17 00:00:00 2001
From: dtc <dtc>
Date: Thu, 13 Jan 2000 16:53:33 +0000
Subject: [PATCH] Modify the sxhash double-float and long-float functions to
 allow them to be compiled to fast native code, and to make use of the sign
 bit. Fix and update the sxhash double-float transform to be consistent. Add a
 transform for the sxhash of long-floats.

---
 code/hash-new.lisp            | 35 ++++++++++++++++-------------------
 code/hash.lisp                | 28 +++++++++++++++++++---------
 compiler/generic/vm-tran.lisp | 30 ++++++++++++++++++++----------
 3 files changed, 55 insertions(+), 38 deletions(-)

diff --git a/code/hash-new.lisp b/code/hash-new.lisp
index f19264705..802701570 100644
--- a/code/hash-new.lisp
+++ b/code/hash-new.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/hash-new.lisp,v 1.5 1999/12/04 16:02:35 dtc Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/hash-new.lisp,v 1.6 2000/01/13 16:53:23 dtc Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -901,29 +901,26 @@
        (single-float
 	(let ((bits (single-float-bits s-expr)))
 	  (ldb sxhash-bits-byte
-	       (logxor (ash bits (- sxmash-rotate-bits))
-		       bits))))
+	       (logxor (ash bits (- sxmash-rotate-bits)) bits))))
        (double-float
-	(let* ((val s-expr)
-	       (lo (double-float-low-bits val))
-	       (hi (ldb sxhash-bits-byte (double-float-high-bits val))))
+	(let ((lo (double-float-low-bits s-expr))
+	      (hi (double-float-high-bits s-expr)))
 	  (ldb sxhash-bits-byte
-	       (logxor (ash lo (- sxmash-rotate-bits))
-		       (ash hi (- sxmash-rotate-bits))
-		       lo hi))))
+	       (logxor (ash lo (- sxmash-rotate-bits)) lo
+		       (ldb sxhash-bits-byte
+			    (logxor (ash hi (- sxmash-rotate-bits)) hi))))))
        #+long-float
        (long-float
-	(let* ((val s-expr)
-	       (lo (long-float-low-bits val))
-	       #+sparc (mid (long-float-mid-bits val))
-	       (hi (long-float-high-bits val))
-	       (exp (long-float-exp-bits val)))
+	(let ((lo (long-float-low-bits s-expr))
+	      #+sparc (mid (long-float-mid-bits s-expr))
+	      (hi (long-float-high-bits s-expr))
+	      (exp (long-float-exp-bits s-expr)))
 	  (ldb sxhash-bits-byte
-	       (logxor (ash lo (- sxmash-rotate-bits))
-		       #+sparc (ash mid (- sxmash-rotate-bits))
-		       (ash hi (- sxmash-rotate-bits))
-		       (ash exp (- sxmash-rotate-bits))
-		       lo hi exp))))
+	       (logxor (ash lo (- sxmash-rotate-bits)) lo
+		       #+sparc (ash mid (- sxmash-rotate-bits)) #+sparc mid
+		       (ash hi (- sxmash-rotate-bits)) hi
+		       (ldb sxhash-bits-byte
+			    (logxor (ash exp (- sxmash-rotate-bits)) exp))))))
        (ratio (logxor (internal-sxhash (numerator s-expr) 0)
 		      (internal-sxhash (denominator s-expr) 0)))
        (complex (logxor (internal-sxhash (realpart s-expr) 0)
diff --git a/code/hash.lisp b/code/hash.lisp
index c0a544728..37351fd21 100644
--- a/code/hash.lisp
+++ b/code/hash.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/hash.lisp,v 1.29 1994/10/31 04:11:27 ram Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/hash.lisp,v 1.30 2000/01/13 16:53:24 dtc Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -870,16 +870,26 @@
        (single-float
 	(let ((bits (single-float-bits s-expr)))
 	  (ldb sxhash-bits-byte
-	       (logxor (ash bits (- sxmash-rotate-bits))
-		       bits))))
+	       (logxor (ash bits (- sxmash-rotate-bits)) bits))))
        (double-float
-	(let* ((val s-expr)
-	       (lo (double-float-low-bits val))
-	       (hi (ldb sxhash-bits-byte (double-float-high-bits val))))
+	(let ((lo (double-float-low-bits s-expr))
+	      (hi (double-float-high-bits s-expr)))
 	  (ldb sxhash-bits-byte
-	       (logxor (ash lo (- sxmash-rotate-bits))
-		       (ash hi (- sxmash-rotate-bits))
-		       lo hi))))
+	       (logxor (ash lo (- sxmash-rotate-bits)) lo
+		       (ldb sxhash-bits-byte
+			    (logxor (ash hi (- sxmash-rotate-bits)) hi))))))
+       #+long-float
+       (long-float
+	(let ((lo (long-float-low-bits s-expr))
+	      #+sparc (mid (long-float-mid-bits s-expr))
+	      (hi (long-float-high-bits s-expr))
+	      (exp (long-float-exp-bits s-expr)))
+	  (ldb sxhash-bits-byte
+	       (logxor (ash lo (- sxmash-rotate-bits)) lo
+		       #+sparc (ash mid (- sxmash-rotate-bits)) #+sparc mid
+		       (ash hi (- sxmash-rotate-bits)) hi
+		       (ldb sxhash-bits-byte
+			    (logxor (ash exp (- sxmash-rotate-bits)) exp))))))
        (ratio (logxor (internal-sxhash (numerator s-expr) 0)
 		      (internal-sxhash (denominator s-expr) 0)))
        (complex (logxor (internal-sxhash (realpart s-expr) 0)
diff --git a/compiler/generic/vm-tran.lisp b/compiler/generic/vm-tran.lisp
index b4cf9d140..2c15eba38 100644
--- a/compiler/generic/vm-tran.lisp
+++ b/compiler/generic/vm-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/generic/vm-tran.lisp,v 1.37 1999/09/06 06:49:28 dtc Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/generic/vm-tran.lisp,v 1.38 2000/01/13 16:53:33 dtc Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -331,18 +331,28 @@
 (deftransform sxhash ((s-expr) (single-float))
   '(let ((bits (single-float-bits s-expr)))
      (ldb sxhash-bits-byte
-	  (logxor (ash bits (- sxmash-rotate-bits))
-		  bits))))
+	  (logxor (ash bits (- sxmash-rotate-bits)) bits))))
 
 (deftransform sxhash ((s-expr) (double-float))
-  '(let* ((val s-expr)
-	  (lo (double-float-low-bits val))
-	  (hi (double-float-high-bits val)))
+  '(let* ((lo (double-float-low-bits s-expr))
+	  (hi (double-float-high-bits s-expr)))
      (ldb sxhash-bits-byte
-	  (logxor (ash lo (- sxmash-rotate-bits))
-		  (ash hi (- sxmash-rotate-bits))
-		  lo hi))))
-
+	  (logxor (ash lo (- sxmash-rotate-bits)) lo
+		  (ldb sxhash-bits-byte
+		       (logxor (ash hi (- sxmash-rotate-bits)) hi))))))
+
+#+long-float
+(deftransform sxhash ((s-expr) (long-float))
+  '(let* ((lo (long-float-low-bits s-expr))
+	  #+sparc (mid (long-float-mid-bits s-expr))
+	  (hi (long-float-high-bits s-expr))
+	  (exp (long-float-exp-bits s-expr)))
+     (ldb sxhash-bits-byte
+	  (logxor (ash lo (- sxmash-rotate-bits)) lo
+		  #+sparc (ash mid (- sxmash-rotate-bits)) #+sparc mid
+		  (ash hi (- sxmash-rotate-bits)) hi
+		  (ldb sxhash-bits-byte
+		       (logxor (ash exp (- sxmash-rotate-bits)) exp))))))
 
 
 ;;;; Float EQL transforms.
-- 
GitLab