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 a587ca64d7ac3873dcad27baba02701644cd5c2f..b550edfb3e65d53f838a6d90b649c3c828ac7b48 100644 (file)
--- 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 **);
 \f
-#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 080154a9b99cab8620dffc607da4c00296bbea5c..8eaff600a538d3eb8dff4b5dabf9a1a04bdb8507 100644 (file)
--- 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))))))
 \f
 ;;;; Constructing and Open-Coding Types and Constructors
 

diff --git a/src/runtime/microcode-tables.scm b/src/runtime/microcode-tables.scm
index ff26f220cf2618a488d220e70e3e75dc9d5e514c..ae356daa06a5e764b2e40bd08be05290743f3dbe 100644 (file)
--- 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 c73ba2b1c6822297f96e5f137e126aa496760f98..4c0f7d2ecd516b6bf4d99c61c745d2d243d6fd86 100644 (file)
--- 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