From: Chris Hanson Date: Wed, 25 Apr 2018 05:56:12 +0000 (-0700) Subject: Rewrite the object hashing facility. X-Git-Tag: mit-scheme-pucked-x11-0.3.1~7^2~110 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=fdac71c8382601b5876460d4ffdc63fe70ea7285;p=mit-scheme.git Rewrite the object hashing facility. * Names have been changed to avoid conflicts with hash tables, and for consistency. The old names are still available as deprecated renames. * New implementation is much easier to read. --- diff --git a/doc/ref-manual/associations.texi b/doc/ref-manual/associations.texi index c84fb5da9..e1b5ac4b2 100644 --- a/doc/ref-manual/associations.texi +++ b/doc/ref-manual/associations.texi @@ -1032,31 +1032,31 @@ but it may be used for other things as well. In particular, it is used in the generation of the written representation for many objects (@pxref{Custom Output}). -All of these procedures accept an optional argument called @var{table}; -this table contains the object-integer associations. If given, this -argument must be an object-hash table as constructed by -@code{hash-table/make} (see below). If not given, a default table is -used. +All of these procedures accept an optional argument called +@var{hasher} which contains the object-integer associations. If +given, this argument must be an object hasher as constructed by +@code{make-object-hasher} (see below). If not given, a default table +is used. -@deffn procedure hash object [table] +@deffn procedure hash-object object [hasher] @findex eq? -@code{hash} associates an exact non-negative integer with @var{object} -and returns that integer. If @code{hash} was previously called with -@var{object} as its argument, the integer returned is the same as was -returned by the previous call. @code{hash} guarantees that distinct -objects (in the sense of @code{eq?}) are associated with distinct -integers. -@end deffn - -@deffn procedure unhash k [table] -@code{unhash} takes an exact non-negative integer @var{k} and returns -the object associated with that integer. If there is no object -associated with @var{k}, or if the object previously associated with -@var{k} has been reclaimed by the garbage collector, an error of type -@code{condition-type:bad-range-argument} is signalled. In other words, -if @code{hash} previously returned @var{k} for some object, and that -object has not been reclaimed, it is the value of the call to -@code{unhash}. +@code{hash-object} associates an exact non-negative integer with +@var{object} and returns that integer. If @code{hash-object} was +previously called with @var{object} as its argument, the integer +returned is the same as was returned by the previous call. +@code{hash-object} guarantees that distinct objects (in the sense of +@code{eqv?}) are associated with distinct integers. +@end deffn + +@deffn procedure unhash-object k [hasher] +@code{unhash-object} takes an exact non-negative integer @var{k} and +returns the object associated with that integer. If there is no +object associated with @var{k}, or if the object previously associated +with @var{k} has been reclaimed by the garbage collector, an error of +type @code{condition-type:bad-range-argument} is signalled. In other +words, if @code{hash-object} previously returned @var{k} for some +object, and that object has not been reclaimed, it is the value of the +call to @code{unhash-object}. @findex condition-type:bad-range-argument @end deffn @@ -1069,60 +1069,30 @@ reclaimed) object will signal an error. @example @group (define x (cons 0 0)) @result{} @r{unspecified} -(hash x) @result{} 77 -(eqv? (hash x) (hash x)) @result{} #t +(hash-object x) @result{} 77 +(eqv? (hash-object x) + (hash-object x)) @result{} #t (define x 0) @result{} @r{unspecified} (gc-flip) @r{;force a garbage collection} -(unhash 77) @error{} +(unhash-object 77) @error{} @end group @end example -@deffn procedure object-hashed? object [table] -This predicate is true if @var{object} has an associated hash number. -Otherwise it is false. +@deffn procedure object-hashed? object [hasher] +This predicate is true iff @var{object} has an associated hash number. @end deffn -@deffn procedure valid-hash-number? k [table] -This predicate is true if @var{k} is the hash number associated with -some object. Otherwise it is false. +@deffn procedure valid-object-hash? k [hasher] +This predicate is true iff @var{k} is the hash number associated with +some object. @end deffn -The following two procedures provide a lower-level interface to the -object-hashing mechanism. +Finally, this procedure makes new object hashers: -@deffn procedure object-hash object [table [insert?]] -@findex eq? -@code{object-hash} is like @code{hash}, except that it accepts an -additional optional argument, @var{insert?}. If @var{insert?}@: is -supplied and is @code{#f}, @code{object-hash} will return an integer for -@var{object} only if there is already an association in the table; -otherwise, it will return @code{#f}. If @var{insert?} is not supplied, -or is not @code{#f}, @code{object-hash} always returns an integer, -creating an association in the table if necessary. - -@code{object-hash} additionally treats @code{#f} differently than does -@code{hash}. Calling @code{object-hash} with @code{#f} as its argument -will return an integer that, when passed to @code{unhash}, will signal -an error rather than returning @code{#f}. Likewise, -@code{valid-hash-number?} will return @code{#f} for this integer. -@end deffn - -@deffn procedure object-unhash k [table] -@code{object-unhash} is like @code{unhash}, except that when @var{k} is -not associated with any object or was previously associated with an -object that has been reclaimed, @code{object-unhash} returns @code{#f}. -This means that there is an ambiguity in the value returned by -@code{object-unhash}: if @code{#f} is returned, there is no way to -tell if @var{k} is associated with @code{#f} or is not associated with -any object at all. -@end deffn - -Finally, this procedure makes new object-hash tables: - -@deffn procedure hash-table/make -This procedure creates and returns a new, empty object-hash table that -is suitable for use as the optional @var{table} argument to the above -procedures. The returned table contains no associations. +@deffn procedure make-object-hasher +This procedure creates and returns a new, empty object hasher that +is suitable for use as the optional @var{hasher} argument to the above +procedures. The returned hasher contains no associations. @end deffn @node Red-Black Trees, Weight-Balanced Trees, Object Hashing, Associations diff --git a/src/compiler/base/object.scm b/src/compiler/base/object.scm index 2ae868bd9..8712258c2 100644 --- a/src/compiler/base/object.scm +++ b/src/compiler/base/object.scm @@ -119,7 +119,7 @@ USA. (define (->tagged-vector object) (let ((object (if (exact-nonnegative-integer? object) - (unhash object) + (unhash-object object) object))) (and (or (tagged-vector? object) (named-structure? object)) diff --git a/src/compiler/rtlopt/rcse2.scm b/src/compiler/rtlopt/rcse2.scm index b2a3e0c41..4642e385c 100644 --- a/src/compiler/rtlopt/rcse2.scm +++ b/src/compiler/rtlopt/rcse2.scm @@ -129,7 +129,7 @@ USA. (cond ((integer? object) (inexact->exact object)) ((symbol? object) (symbol-hash object)) ((string? object) (string-hash object)) - (else (hash object)))))) + (else (hash-object object)))))) (let ((hash (loop expression))) (receiver (modulo hash (rcse-ht-size)) diff --git a/src/compiler/rtlopt/rdebug.scm b/src/compiler/rtlopt/rdebug.scm index 11590d746..9708b0b0e 100644 --- a/src/compiler/rtlopt/rdebug.scm +++ b/src/compiler/rtlopt/rdebug.scm @@ -50,7 +50,7 @@ USA. (write-string "; multiple blocks"))) (bblock (write-string "; block ") - (write (unhash bblock))) + (write (unhash-object bblock))) (else (write-string "; no block!")))))))))) diff --git a/src/edwin/evlcom.scm b/src/edwin/evlcom.scm index 83ef83d57..7634633ca 100644 --- a/src/edwin/evlcom.scm +++ b/src/edwin/evlcom.scm @@ -528,7 +528,7 @@ Set by Scheme evaluation code to update the mode line." (not (number? value))) (string-append " " - (write-to-string (object-hash value))) + (write-to-string (hash-object value))) "") ": "))) diff --git a/src/edwin/regcom.scm b/src/edwin/regcom.scm index 46cf655f1..c8117d399 100644 --- a/src/edwin/regcom.scm +++ b/src/edwin/regcom.scm @@ -175,7 +175,7 @@ With prefix arg, delete as well." '()) (define (make-buffer-position mark buffer) - (cons buffer-position-tag (cons mark (hash buffer)))) + (cons buffer-position-tag (cons mark (hash-object buffer)))) (define (buffer-position? object) (and (pair? object) @@ -188,4 +188,4 @@ With prefix arg, delete as well." (cadr position)) (define-integrable (buffer-position-buffer position) - (unhash (cddr position))) \ No newline at end of file + (unhash-object (cddr position))) \ No newline at end of file diff --git a/src/edwin/regexp.scm b/src/edwin/regexp.scm index d2dfebe3e..661c044b4 100644 --- a/src/edwin/regexp.scm +++ b/src/edwin/regexp.scm @@ -28,7 +28,7 @@ USA. (declare (usual-integrations)) -(define hash-of-false (object-hash #f)) +(define hash-of-false (hash-object #f)) (define match-group hash-of-false) (define (re-match-start i) @@ -48,13 +48,13 @@ USA. (re-match-end-index i))) (define (re-match-group) - (let ((group (object-unhash match-group))) + (let ((group (unhash-object match-group))) (if (not group) (error "No match group")) group)) (define (re-match-data) - (let ((group (object-unhash match-group))) + (let ((group (unhash-object match-group))) (cons group (if group (let ((v (make-vector 20))) diff --git a/src/edwin/struct.scm b/src/edwin/struct.scm index 5ba5e7623..2080c6bd4 100644 --- a/src/edwin/struct.scm +++ b/src/edwin/struct.scm @@ -192,7 +192,7 @@ USA. (define (group-hash-number group) (or (group-%hash-number group) - (let ((n (object-hash group))) + (let ((n (hash-object group))) (set-group-%hash-number! group n) n))) diff --git a/src/runtime/boot.scm b/src/runtime/boot.scm index 7ac9cd8fd..73a960fd8 100644 --- a/src/runtime/boot.scm +++ b/src/runtime/boot.scm @@ -324,7 +324,7 @@ USA. (if (get-param:unparse-with-maximum-readability?) (begin (write-string "#@" port) - (write (object-hash object) port)) + (write (hash-object object) port)) (procedure object port)))))) (define (bracketed-unparser-method procedure) @@ -342,7 +342,7 @@ USA. name) port) (write-char #\space port) - (write (object-hash object) port) + (write (hash-object object) port) (if procedure (procedure object port))))) (define (simple-unparser-method name get-parts) diff --git a/src/runtime/hash.scm b/src/runtime/hash.scm index ed0967372..7a64a4db0 100644 --- a/src/runtime/hash.scm +++ b/src/runtime/hash.scm @@ -27,122 +27,84 @@ USA. ;;;; Object Hashing ;;; package: (runtime hash) -(declare (usual-integrations)) - -;;;; Object hashing - ;;; How this works: -;;; There are two tables, the hash table and the unhash table: +;;; There are two tables: -;;; - The hash table associates objects to their hash numbers. The -;;; entries are keyed according to the address (datum) of the object. +;;; * The hash table associates objects (as compared by eqv?) to their hash +;;; numbers. -;;; - The unhash table associates the hash numbers with the -;;; corresponding objects. It is keyed according to the numbers -;;; themselves. +;;; * The unhash table associates the hash numbers back to the hashed objects. -;;; Both tables hold the objects weakly. Thus the hash table holds -;;; its keys weakly, and the unhash table holds its values weakly. - -(define default/hash-table-size 313) -(define default-hash-table) - -(define (initialize-package!) - (set! make-datum-weak-eq-hash-table - (hash-table-constructor - (make-hash-table-type eq-hash-mod eq? #f - hash-table-entry-type:datum-weak))) - (set! default-hash-table (hash-table/make))) - -(define-structure (hash-table - (conc-name hash-table/) - (constructor %hash-table/make)) - (mutex) - (next-number) - (hash-table) - (unhash-table)) - -(define make-datum-weak-eq-hash-table) - -(define (hash-table/make #!optional size) - (let ((size (if (default-object? size) - default/hash-table-size - size))) - (%hash-table/make - (make-thread-mutex) - 1 - (make-key-weak-eq-hash-table size) - (make-datum-weak-eq-hash-table size)))) - -(define (hash x #!optional table) - (if (eq? x #f) - 0 - (object-hash x - (if (default-object? table) default-hash-table table) - #t))) - -(define (unhash n #!optional table) - (if (= n 0) - #f - (let ((object - (object-unhash n - (if (default-object? table) - default-hash-table - table)))) - (if (not object) - (error:bad-range-argument n 'unhash)) - object))) - -(define (valid-hash-number? n #!optional table) - (or (= n 0) - (object-unhash n (if (default-object? table) default-hash-table table)))) - -(define (object-hashed? x #!optional table) - (or (eq? x #f) - (object-hash x - (if (default-object? table) default-hash-table table) - #f))) +;;; Both tables hold the objects weakly; the hash table holds its keys weakly, +;;; and the unhash table holds its values weakly. + +(declare (usual-integrations)) -(define (object-hash object #!optional table insert?) - (let ((table - (if (default-object? table) - default-hash-table - (begin - (if (not (hash-table? table)) - (error:wrong-type-argument table - "object-hash table" - 'object-hash)) - table))) - (insert? (or (default-object? insert?) insert?))) - (with-thread-mutex-lock (hash-table/mutex table) - (lambda () - (let ((number - (hash-table-ref/default (hash-table/hash-table table) - object - #f))) - (if (not number) - (if insert? - (let ((hashtb (hash-table/hash-table table)) - (unhashtb (hash-table/unhash-table table)) - (next (hash-table/next-number table))) - (set-hash-table/next-number! table (1+ next)) - (hash-table-set! unhashtb next object) - (hash-table-set! hashtb object next) - next) - number) - number)))))) - -(define (object-unhash number #!optional table) - (let ((table - (if (default-object? table) - default-hash-table - (begin - (if (not (hash-table? table)) - (error:wrong-type-argument table - "object-hash table" - 'object-unhash)) - table)))) - (with-thread-mutex-lock (hash-table/mutex table) - (lambda () - (hash-table-ref/default (hash-table/unhash-table table) number #f))))) \ No newline at end of file +(define (hash-object object #!optional hasher) + ((get-operation hasher 'hash-object) object)) + +(define (object-hashed? object #!optional hasher) + ((get-operation hasher 'object-hashed?) object)) + +(define (unhash-object hash #!optional hasher) + ((get-operation hasher 'unhash-object) hash)) + +(define (valid-object-hash? hash #!optional hasher) + ((get-operation hasher 'valid-object-hash?) hash)) + +(define (get-operation hasher operator) + ((if (default-object? hasher) + default-object-hasher + hasher) + operator)) + +(define-deferred default-object-hasher + (make-object-hasher 313)) + +(define (make-object-hasher #!optional initial-size) + (let ((mutex (make-thread-mutex)) + (next-hash 1) + (hash-table (make-key-weak-eqv-hash-table initial-size)) + (unhash-table (make-datum-weak-eqv-hash-table initial-size))) + + (define (hash-object object) + (if (eq? object #f) + 0 + (with-thread-mutex-lock mutex + (lambda () + (hash-table-intern! hash-table object + (lambda () + (let ((hash next-hash)) + (set! next-hash (+ next-hash 1)) + (hash-table-set! unhash-table hash object) + hash))))))) + + (define (object-hashed? object) + (or (eq? object #f) + (with-thread-mutex-lock mutex + (lambda () + (hash-table-exists? hash-table object))))) + + (define (unhash-object hash) + (guarantee exact-nonnegative-integer? hash 'unhash-object) + (if (= hash 0) + #f + (with-thread-mutex-lock mutex + (lambda () + (hash-table-ref unhash-table hash))))) + + (define (valid-object-hash? hash) + (guarantee exact-nonnegative-integer? hash 'valid-object-hash?) + (or (= hash 0) + (with-thread-mutex-lock mutex + (lambda () + (hash-table-exists? unhash-table hash))))) + + (lambda (operator) + (case operator + ((hash-object) hash-object) + ((object-hashed?) object-hashed?) + ((unhash-object) unhash-object) + ((valid-object-hash?) valid-object-hash?) + (else (error "Unknown operator:" operator)))))) \ No newline at end of file diff --git a/src/runtime/parser.scm b/src/runtime/parser.scm index d65c0409f..8b4963ce1 100644 --- a/src/runtime/parser.scm +++ b/src/runtime/parser.scm @@ -593,7 +593,7 @@ USA. (error:illegal-unhash object)) (if (eq? object 0) #f - (or (object-unhash object) + (or (unhash-object object) (error:undefined-hash object)))) (define (handler:quote db ctx char) diff --git a/src/runtime/prop2d.scm b/src/runtime/prop2d.scm index d33675df1..039e93dc7 100644 --- a/src/runtime/prop2d.scm +++ b/src/runtime/prop2d.scm @@ -38,8 +38,8 @@ USA. (define system-properties) (define (2d-put! x y value) - (let ((x-hash (object-hash x)) - (y-hash (object-hash y))) + (let ((x-hash (hash-object x)) + (y-hash (hash-object y))) (let ((bucket (assq x-hash system-properties))) (if bucket (let ((entry (assq y-hash (cdr bucket)))) @@ -55,9 +55,9 @@ USA. system-properties)))))) (define (2d-get x y) - (let ((bucket (assq (object-hash x) system-properties))) + (let ((bucket (assq (hash-object x) system-properties))) (and bucket - (let ((entry (assq (object-hash y) (cdr bucket)))) + (let ((entry (assq (hash-object y) (cdr bucket)))) (and entry (cdr entry)))))) @@ -65,14 +65,14 @@ USA. ;;; Removes the bucket if the entry removed was the only entry. (define (2d-remove! x y) - (let ((bucket (assq (object-hash x) system-properties))) + (let ((bucket (assq (hash-object x) system-properties))) (and bucket (begin (set-cdr! bucket - (del-assq! (object-hash y) + (del-assq! (hash-object y) (cdr bucket))) (if (null? (cdr bucket)) (set! system-properties - (del-assq! (object-hash x) + (del-assq! (hash-object x) system-properties))) true)))) @@ -83,36 +83,36 @@ USA. (set! system-properties (delete-invalid-hash-numbers! system-properties))) (define (filter-bucket! bucket) - (or (not (valid-hash-number? (car bucket))) + (or (not (valid-object-hash? (car bucket))) (begin (set-cdr! bucket (delete-invalid-y! (cdr bucket))) (null? (cdr bucket))))) (define (filter-entry! entry) - (not (valid-hash-number? (car entry)))) + (not (valid-object-hash? (car entry)))) (define delete-invalid-hash-numbers!) (define delete-invalid-y!) (define (2d-get-alist-x x) - (let ((bucket (assq (object-hash x) system-properties))) + (let ((bucket (assq (hash-object x) system-properties))) (if bucket (let loop ((rest (cdr bucket))) (cond ((null? rest) '()) - ((valid-hash-number? (caar rest)) - (cons (cons (object-unhash (caar rest)) + ((valid-object-hash? (caar rest)) + (cons (cons (unhash-object (caar rest)) (cdar rest)) (loop (cdr rest)))) (else (loop (cdr rest))))) '()))) (define (2d-get-alist-y y) - (let ((y-hash (object-hash y))) + (let ((y-hash (hash-object y))) (let loop ((rest system-properties)) (cond ((null? rest) '()) - ((valid-hash-number? (caar rest)) + ((valid-object-hash? (caar rest)) (let ((entry (assq y-hash (cdar rest)))) (if entry - (cons (cons (object-unhash (caar rest)) + (cons (cons (unhash-object (caar rest)) (cdr entry)) (loop (cdr rest))) (loop (cdr rest))))) diff --git a/src/runtime/rep.scm b/src/runtime/rep.scm index 63f2da82a..9699abc67 100644 --- a/src/runtime/rep.scm +++ b/src/runtime/rep.scm @@ -507,7 +507,7 @@ USA. (object-pointer? object) (not (interned-symbol? object)) (not (number? object)) - (object-hash object)) + (hash-object object)) environment)) (define (repl-eval/write s-expression #!optional environment repl) diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg index ffac4dc59..1f779e62f 100644 --- a/src/runtime/runtime.pkg +++ b/src/runtime/runtime.pkg @@ -2358,15 +2358,19 @@ USA. (define-package (runtime hash) (files "hash") (parent (runtime)) - (export () - hash - hash-table/make - object-hash + (export () deprecated:hash + (hash hash-object) + (hash-table/make make-object-hasher) + (object-hash hash-object) + (object-unhash unhash-object) + (unhash unhash-object) + (valid-hash-number? valid-object-hash?)) + (export () + hash-object + make-object-hasher object-hashed? - object-unhash - unhash - valid-hash-number?) - (initialization (initialize-package!))) + unhash-object + valid-object-hash?)) (define-package (runtime hash-table) (files "hash-table") diff --git a/src/runtime/swank.scm b/src/runtime/swank.scm index 45dc1c87a..be1d11289 100644 --- a/src/runtime/swank.scm +++ b/src/runtime/swank.scm @@ -241,7 +241,7 @@ USA. (get-current-environment)) ((string-prefix? anonymous-package-prefix pstring) (let ((object - (object-unhash + (unhash-object (string->number (string-tail pstring (string-length anonymous-package-prefix)) @@ -257,7 +257,7 @@ USA. (let ((package (environment->package env))) (if package (write-to-string (package/name package)) - (string anonymous-package-prefix (object-hash env))))) + (string anonymous-package-prefix (hash-object env))))) (define anonymous-package-prefix "environment-") @@ -283,7 +283,7 @@ USA. (let ((value (repl-eval sexp socket))) (call-with-output-string (lambda (port) - (port/write-result port sexp value (object-hash value) (buffer-env)) + (port/write-result port sexp value (hash-object value) (buffer-env)) (if nl? (newline port)))))) (define (for-each-sexp procedure string) diff --git a/src/runtime/unpars.scm b/src/runtime/unpars.scm index 472d8fe80..e6ab9fc2c 100644 --- a/src/runtime/unpars.scm +++ b/src/runtime/unpars.scm @@ -344,7 +344,7 @@ USA. (*unparse-string (number->string number 16) context)) (define-integrable (*unparse-hash object context) - (*unparse-string (number->string (hash object)) context)) + (*unparse-string (number->string (hash-object object)) context)) (define (*unparse-readable-hash object context) (*unparse-string "#@" context) diff --git a/src/runtime/world-report.scm b/src/runtime/world-report.scm index 153b1b768..52b2519b0 100644 --- a/src/runtime/world-report.scm +++ b/src/runtime/world-report.scm @@ -170,7 +170,7 @@ USA. '())) flags)) (newline port))) - (sort (map (lambda (t) (cons (hash t) t)) (threads-list)) + (sort (map (lambda (t) (cons (hash-object t) t)) (threads-list)) (lambda (a b) (< (car a) (car b)))))) (define (write-state thread port) diff --git a/src/sos/printer.scm b/src/sos/printer.scm index 1c0548402..07a01af14 100644 --- a/src/sos/printer.scm +++ b/src/sos/printer.scm @@ -87,7 +87,7 @@ USA. (if object (begin (write-char #\space port) - (write (hash object) port))) + (write (hash-object object) port))) (if thunk (thunk)) (write-char #\] port)) diff --git a/src/xml/rdf-struct.scm b/src/xml/rdf-struct.scm index d31561b39..a5a5b3958 100644 --- a/src/xml/rdf-struct.scm +++ b/src/xml/rdf-struct.scm @@ -165,7 +165,7 @@ USA. (hash-table-intern! *rdf-bnode-registry* name %make-rdf-bnode)))) (define (rdf-bnode-name bnode) - (string-append "B" (number->string (hash bnode)))) + (string-append "B" (number->string (hash-object bnode)))) (define (%decode-bnode-uri uri) (let ((v @@ -173,7 +173,7 @@ USA. ((symbol? uri) (*parse-symbol parse-bnode uri)) (else #f)))) (and v - (unhash (vector-ref v 0))))) + (unhash-object (vector-ref v 0))))) (define parse-bnode (let ((digits (ascii-range->char-set #x30 #x3A)))