From: Chris Hanson <org/chris-hanson/cph>
Date: Tue, 27 Nov 2018 07:18:35 +0000 (-0800)
Subject: Implement binary-hash-by-X; some hair to guarantee fixnum result.
X-Git-Tag: mit-scheme-pucked-10.1.7~3^2~140
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=ff9e85873c429fbc798ac558ab91ecd2422bd99b;p=mit-scheme.git

Implement binary-hash-by-X; some hair to guarantee fixnum result.

Not nearly as fast as the underlying unary hash, but for now that's OK.  If need
be we can make it faster.
---

diff --git a/src/microcode/utabmd.c b/src/microcode/utabmd.c
index a587ca64d..b550edfb3 100644
--- a/src/microcode/utabmd.c
+++ b/src/microcode/utabmd.c
@@ -46,7 +46,7 @@ static SCHEME_OBJECT fixed_objects_syscall_names (void);
 static SCHEME_OBJECT fixed_objects_syserr_names (void);
 static SCHEME_OBJECT names_to_vector (unsigned long, const char **);
 
-#define IDENTITY_LENGTH 	20	/* Plenty of room */
+#define IDENTITY_LENGTH		20	/* Plenty of room */
 #define ID_RELEASE		0	/* System release (string) */
 #define ID_MICRO_VERSION	1	/* Microcode version (fixnum) */
 /* 2 unused */
@@ -62,8 +62,10 @@ static SCHEME_OBJECT names_to_vector (unsigned long, const char **);
 #define ID_CC_ARCH		12	/* Compiled-code support (string) */
 #define ID_FLONUM_EXP_MIN	13	/* Minimum finite (normal) exponent */
 #define ID_FLONUM_EXP_MAX	14	/* Maximum finite exponent */
+#define ID_NONNEG_FIXNUM_LENGTH	15	/* Number of bits in nonneg. fixnum */
+#define ID_NONNEG_FIXNUM_MASK	16	/* Mask for nonneg. fixnum */
 
-#define N_IDENTITY_NAMES 0x0F
+#define N_IDENTITY_NAMES 0x11
 static const char * identity_names [] =
 {
   /* 0x00 */	"system-release-string",
@@ -81,6 +83,8 @@ static const char * identity_names [] =
   /* 0x0C */	"cc-arch-string",
   /* 0x0D */	"flonum-exponent-min",
   /* 0x0E */	"flonum-exponent-max",
+  /* 0x0F */	"nonnegative-fixnum-length",
+  /* 0x10 */	"nonnegative-fixnum-mask",
 };
 
 SCHEME_OBJECT
@@ -100,6 +104,8 @@ make_microcode_identification_vector (void)
   VECTOR_SET (v, ID_MACHINE_TYPE, (char_pointer_to_string (MACHINE_TYPE)));
   VECTOR_SET (v, ID_FLONUM_EXP_MIN, (LONG_TO_FIXNUM (DBL_MIN_EXP - 1)));
   VECTOR_SET (v, ID_FLONUM_EXP_MAX, (LONG_TO_FIXNUM (DBL_MAX_EXP - 1)));
+  VECTOR_SET (v, ID_NONNEG_FIXNUM_LENGTH, (ULONG_TO_FIXNUM (FIXNUM_LENGTH)));
+  VECTOR_SET (v, ID_NONNEG_FIXNUM_MASK, (ULONG_TO_FIXNUM (FIXNUM_MASK)));
   {
     const char * name = (cc_arch_name ());
     if (name != 0)
diff --git a/src/runtime/hash-table.scm b/src/runtime/hash-table.scm
index 080154a9b..8eaff600a 100644
--- a/src/runtime/hash-table.scm
+++ b/src/runtime/hash-table.scm
@@ -1008,6 +1008,31 @@ USA.
 
 (define-integrable (equal-hash-mod key modulus)
   (fix:remainder (equal-hash key) modulus))
+
+(define (binary-hash-by-identity object1 object2 #!optional modulus)
+  (binary-hash eq-hash object1 object2 modulus))
+
+(define (binary-hash-by-eqv object1 object2 #!optional modulus)
+  (binary-hash eqv-hash object1 object2 modulus))
+
+(define (binary-hash-by-equal object1 object2 #!optional modulus)
+  (binary-hash equal-hash object1 object2 modulus))
+
+;;; Assumes that hash-fn always returns a nonnegative fixnum.
+(define-integrable (binary-hash hash-fn object1 object2 modulus)
+  (let ((sum
+	 (+ (* 31 (hash-fn object1))
+	    (hash-fn object2))))
+    (if (default-object? modulus)
+	(if (fix:fixnum? sum)
+	    sum
+	    (fix:xor (shift-right sum microcode-id/nonnegative-fixnum-length)
+		     (bitwise-and sum microcode-id/nonnegative-fixnum-mask)))
+	(begin
+	  (guarantee positive-fixnum? modulus 'binary-eq-hash-mod)
+	  (if (fix:fixnum? sum)
+	      (fix:remainder sum modulus)
+	      (modulo sum modulus))))))
 
 ;;;; Constructing and Open-Coding Types and Constructors
 
diff --git a/src/runtime/microcode-tables.scm b/src/runtime/microcode-tables.scm
index ff26f220c..ae356daa0 100644
--- a/src/runtime/microcode-tables.scm
+++ b/src/runtime/microcode-tables.scm
@@ -182,6 +182,8 @@ USA.
 (define microcode-id/floating-epsilon)
 (define microcode-id/floating-exponent-min)
 (define microcode-id/floating-exponent-max)
+(define microcode-id/nonnegative-fixnum-length)
+(define microcode-id/nonnegative-fixnum-mask)
 (define microcode-id/operating-system)
 (define microcode-id/operating-system-name)
 (define microcode-id/operating-system-variant)
@@ -200,6 +202,10 @@ USA.
         (microcode-identification-item 'flonum-exponent-min))
   (set! microcode-id/floating-exponent-max
         (microcode-identification-item 'flonum-exponent-max))
+  (set! microcode-id/nonnegative-fixnum-length
+	(microcode-identification-item 'nonnegative-fixnum-length))
+  (set! microcode-id/nonnegative-fixnum-mask
+	(microcode-identification-item 'nonnegative-fixnum-mask))
   (set! microcode-id/operating-system-name
 	(microcode-identification-item 'os-name-string))
   (set! microcode-id/operating-system
diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index c73ba2b1c..4c0f7d2ec 100644
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -2451,6 +2451,9 @@ USA.
 	  weak-hash-table/constructor)
   (export ()
 	  alist->hash-table		;SRFI-69
+	  binary-hash-by-equal
+	  binary-hash-by-eqv
+	  binary-hash-by-identity
 	  datum-weak-eq-hash-table-type
 	  datum-weak-eqv-hash-table-type
 	  eq-hash
@@ -3241,6 +3244,8 @@ USA.
 	  microcode-id/floating-exponent-max
 	  microcode-id/floating-exponent-min
 	  microcode-id/machine-type
+	  microcode-id/nonnegative-fixnum-length
+	  microcode-id/nonnegative-fixnum-mask
 	  microcode-id/operating-system
 	  microcode-id/operating-system-suffix
 	  microcode-id/operating-system-variant