From: Chris Hanson Date: Wed, 23 May 2018 07:18:42 +0000 (-0700) Subject: Use the new hashing primitives to simplify standard hashes. X-Git-Tag: mit-scheme-pucked-x11-0.3.1~7^2~9 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=98bf28cf96d47794f79397eda0f8590feebc07a1;p=mit-scheme.git 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 29c977023..e23fbb204 100644 --- 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 b407177cb..49261b7f5 100644 --- 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 c6b7e223b..a60add01d 100644 --- 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 bd5f8b54c..4f9e58712 100644 --- 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)))) - -(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)) ;;;; Constructing and Open-Coding Types and Constructors diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg index e48cc0dfb..cc1678e36 100644 --- 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 9785a7312..a7d2023fb 100644 --- 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))