Use the new hashing primitives to simplify standard hashes.

Also, the standard hashes now always return a fixnum.

diff --git a/src/runtime/char-set.scm b/src/runtime/char-set.scm
index 29c977023772c7ce6a5b16f2e95dd58b95d2ea9d..e23fbb204602f07389d571a94ead0bf0ea0962bb 100644 (file)
--- a/src/runtime/char-set.scm
+++ b/src/runtime/char-set.scm
@@ -448,6 +448,10 @@ USA.
                              (%char-set-high char-set))))
         char-sets))
 
+(define (char-set-hash char-set)
+  (primitive-object-hash-2 (%char-set-low char-set)
+                          (%char-set-high char-set)))
+
 (define (char-set->code-points char-set)
   (let loop ((ilist (%char-set->inversion-list char-set)) (ranges '()))
     (if (pair? ilist)

diff --git a/src/runtime/equals.scm b/src/runtime/equals.scm
index b407177cbd1b6fb84384806714bdc869d62523d6..49261b7f5b532e70a09a9f7f7c9f578ad4edfb9b 100644 (file)
--- a/src/runtime/equals.scm
+++ b/src/runtime/equals.scm
@@ -79,4 +79,12 @@ USA.
            ((char-set? x)
             (and (char-set? y)
                  (char-set=? x y)))
-           (else #f))))
\ No newline at end of file
+           (else #f))))
+
+(define (equal-hash key)
+  (cond ((primitive-object-hash key))
+       ((string? key) (string-hash key))
+       ((pathname? key) (string-hash (->namestring key)))
+       ((bit-string? key)
+        (primitive-object-hash (bit-string->unsigned-integer key)))
+       (else (eq-hash key))))
\ No newline at end of file

diff --git a/src/runtime/global.scm b/src/runtime/global.scm
index c6b7e223ba1dd4a3ec4b7c3511de759fc54f5cf5..a60add01d0affc2b30f5dc658f83b941c48f22ae 100644 (file)
--- a/src/runtime/global.scm
+++ b/src/runtime/global.scm
@@ -70,7 +70,10 @@ USA.
   system-vector-ref
   system-vector-set!
 
-  primitive-object-ref primitive-object-set!)
+  primitive-object-ref primitive-object-set!
+  (primitive-object-hash 1)
+  (primitive-object-hash-2 2)
+  (primitive-memory-hash 3))
 
 (define (host-big-endian?)
   host-big-endian?-saved)

diff --git a/src/runtime/hash-table.scm b/src/runtime/hash-table.scm
index bd5f8b54c38172a06b32078d51049ebe1d9d6d56..4f9e587127e00ae1d5f1dced295ac6f3b0a5651a 100644 (file)
--- a/src/runtime/hash-table.scm
+++ b/src/runtime/hash-table.scm
@@ -996,69 +996,18 @@ USA.
        n)))
 
 (define-integrable (eqv-hash-mod key modulus)
-  (int:remainder (eqv-hash key) modulus))
+  (fix:remainder (eqv-hash key) modulus))
 
 (define (eqv-hash key)
-  (cond ((%bignum? key) (%bignum->nonneg-int key))
-       ((%ratnum? key) (%ratnum->nonneg-int key))
-       ((flo:flonum? key) (%flonum->nonneg-int key))
-       ((%recnum? key) (%recnum->nonneg-int key))
-       (else (eq-hash key))))
+  (if (or (object-type? (ucode-type bignum) key)
+         (object-type? (ucode-type flonum) key)
+         (object-type? (ucode-type ratnum) key)
+         (object-type? (ucode-type recnum) key))
+      (primitive-object-hash key)
+      (eq-hash key)))
 
 (define-integrable (equal-hash-mod key modulus)
-  (int:remainder (equal-hash key) modulus))
-
-(define (equal-hash key)
-  (cond ((vector? key)
-        (let ((length (vector-length key)))
-          (do ((i 0 (fix:+ i 1))
-               (accum 0 (int:+ accum (equal-hash (vector-ref key i)))))
-              ((not (fix:< i length)) accum))))
-       ((pair? key) (int:+ (equal-hash (car key)) (equal-hash (cdr key))))
-       ((cell? key) (equal-hash (cell-contents key)))
-       ((%bignum? key) (%bignum->nonneg-int key))
-       ((%ratnum? key) (%ratnum->nonneg-int key))
-       ((flo:flonum? key) (%flonum->nonneg-int key))
-       ((%recnum? key) (%recnum->nonneg-int key))
-       ((string? key) (string-hash key))
-       ((bit-string? key) (bit-string->unsigned-integer key))
-       ((pathname? key) (string-hash (->namestring key)))
-       (else (eq-hash key))))
-\f
-(define-integrable (%bignum? object)
-  (object-type? (ucode-type big-fixnum) object))
-
-(define-integrable (%ratnum? object)
-  (object-type? (ucode-type ratnum) object))
-
-(define-integrable (%recnum? object)
-  (object-type? (ucode-type recnum) object))
-
-(define-integrable (%bignum->nonneg-int bignum)
-  (int:abs bignum))
-
-(define-integrable (%ratnum->nonneg-int ratnum)
-  (int:abs (int:+ (system-pair-car ratnum) (system-pair-cdr ratnum))))
-
-(define-integrable (%flonum->nonneg-int flonum)
-  (int:abs
-   (flo:truncate->exact
-    ((ucode-primitive flonum-denormalize 2)
-     (car ((ucode-primitive flonum-normalize 1) flonum))
-     microcode-id/floating-mantissa-bits))))
-
-(define-integrable (%recnum->nonneg-int recnum)
-  (let ((%real->nonneg-int
-        (lambda (real)
-          (cond ((%ratnum? real) (%ratnum->nonneg-int real))
-                ((flo:flonum? real) (%flonum->nonneg-int real))
-                (else (%bignum->nonneg-int real))))))
-    (int:+ (%real->nonneg-int (system-pair-car recnum))
-          (%real->nonneg-int (system-pair-cdr recnum)))))
-
-(declare (integrate-operator int:abs))
-(define (int:abs n)
-  (if (int:negative? n) (int:negate n) n))
+  (fix:remainder (equal-hash key) modulus))
 \f
 ;;;; Constructing and Open-Coding Types and Constructors
 

diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index e48cc0dfb433b4ef169be332d1e29c87246bce21..cc1678e361ad7bcdb0f4c2123718c316de4518c8 100644 (file)
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -225,6 +225,7 @@ USA.
   (files "equals")
   (parent (runtime))
   (export ()
+         equal-hash
          equal?
          eqv?))
 
@@ -573,6 +574,9 @@ USA.
          param:exit-hook
          param:suspend-hook
          pointer-type-code?
+         primitive-memory-hash
+         primitive-object-hash
+         primitive-object-hash-2
          primitive-procedure-arity
          primitive-procedure-documentation
          pwd
@@ -1444,6 +1448,7 @@ USA.
          char-set->code-points
          char-set-difference
          char-set-empty?
+         char-set-hash
          char-set-intersection
          char-set-intersection*
          char-set-invert
@@ -2431,7 +2436,6 @@ USA.
          datum-weak-eqv-hash-table-type
          eq-hash
          eq-hash-mod
-         equal-hash
          equal-hash-mod
          equal-hash-table-type
          equality-predicate-hasher

diff --git a/src/runtime/string.scm b/src/runtime/string.scm
index 9785a7312107c72369d9fa3a241987e9722ce70d..a7d2023fba1662221ebc340f9164b285e3a0ebda 100644 (file)
--- a/src/runtime/string.scm
+++ b/src/runtime/string.scm
@@ -2045,10 +2045,22 @@ USA.
              string))
 
 (define (string-hash string #!optional modulus)
-  (let ((string* (string-for-primitive (string->nfc string))))
-    (if (default-object? modulus)
-       ((ucode-primitive string-hash) string*)
-       ((ucode-primitive string-hash-mod) string* modulus))))
+  (if (default-object? modulus)
+      (%string-hash (string->nfc string))
+      (begin
+       (guarantee index-fixnum? modulus 'string-hash)
+       (if (fix:= 0 modulus)
+           (error:bad-range-argument modulus 'string-hash))
+       (fix:remainder (%string-hash (string->nfc string)) modulus))))
+
+(define (%string-hash string)
+  (primitive-memory-hash string
+                        byte0-index
+                        (fix:+ byte0-index
+                               ;; Simplified since we know this is an immutable
+                               ;; string.
+                               (fix:* (%ustring-cp-size string)
+                                      (ustring-length string)))))
 
 (define (string-ci-hash string #!optional modulus)
   (string-hash (string-foldcase string) modulus))