From 9b55288aa81f1f18b6df080f19a7f4a898cdd4bc Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Thu, 12 Feb 1987 09:08:35 +0000 Subject: [PATCH] Use `modulo' rather than `remainder' to compute index of bucket in the hash table. Reorganize code presentation. --- v7/src/runtime/hash.scm | 338 ++++++++++++++++++++-------------------- 1 file changed, 168 insertions(+), 170 deletions(-) diff --git a/v7/src/runtime/hash.scm b/v7/src/runtime/hash.scm index 3ba2db05f..02e27645b 100644 --- a/v7/src/runtime/hash.scm +++ b/v7/src/runtime/hash.scm @@ -1,6 +1,6 @@ ;;; -*-Scheme-*- ;;; -;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/hash.scm,v 13.42 1987/02/02 14:17:50 jinx Exp $ +;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/hash.scm,v 13.43 1987/02/12 09:08:35 cph Exp $ ;;; ;;; Copyright (c) 1987 Massachusetts Institute of Technology ;;; @@ -39,14 +39,14 @@ ;;;; Object Hashing, populations, and 2D tables -;; The hashing code, and the population code below, depend on weak -;; conses supported by the microcode. In particular, both pieces of -;; code depend on the fact that the car of a weak cons becomes #F if -;; the object is garbage collected. +;;; The hashing code, and the population code below, depend on weak +;;; conses supported by the microcode. In particular, both pieces of +;;; code depend on the fact that the car of a weak cons becomes #F if +;;; the object is garbage collected. -;; Important: This code must be rewritten for a parallel processor, -;; since two processors may be updating the data structures -;; simultaneously. +;;; Important: This code must be rewritten for a parallel processor, +;;; since two processors may be updating the data structures +;;; simultaneously. (declare (usual-integrations)) @@ -54,59 +54,58 @@ ;;;; Object hashing -;; How this works: - -;; There are two tables, the hash table and the unhash table: - -;; - The hash table associates objects to their hash numbers. The -;; entries are keyed according to the address (datum) of the object, -;; and thus must be recomputed after every relocation (ie. band -;; loading, garbage collection, etc.). - -;; - The unhash table associates the hash numbers with the -;; corresponding objects. It is keyed according to the numbers -;; themselves. - -;; In order to make the hash and unhash tables weakly hold the objects -;; hashed, the following mechanism is used: - -;; The hash table, a vector, has a SNMV header before all the buckets, -;; and therefore the garbage collector will skip it and will not -;; relocate its buckets. It becomes invalid after a garbage -;; collection and the first thing the daemon does is clear it. -;; Each bucket is a normal alist with the objects in the cars, and the -;; numbers in the cdrs, thus assq can be used to find an object in the -;; bucket. - -;; The unhash table, also a vector, holds the objects by means of weak -;; conses. These weak conses are the same as the pairs in the buckets -;; in the hash table, but with their type codes changed. Each of the -;; buckets in the unhash table is headed by an extra pair whose car is -;; usually #T. This pair is used by the splicing code. The daemon -;; treats buckets headed by #F differently from buckets headed by #T. -;; A bucket headed by #T is compressed: Those pairs whose cars have -;; disappeared are spliced out from the bucket. On the other hand, -;; buckets headed by #F are not compressed. The intent is that while -;; object-unhash is traversing a bucket, the bucket is locked so that -;; the daemon will not splice it out behind object-unhash's back. -;; Then object-unhash does not need to be locked against garbage -;; collection. - +;;; How this works: + +;;; There are two tables, the hash table and the unhash table: + +;;; - The hash table associates objects to their hash numbers. The +;;; entries are keyed according to the address (datum) of the object, +;;; and thus must be recomputed after every relocation (ie. band +;;; loading, garbage collection, etc.). + +;;; - The unhash table associates the hash numbers with the +;;; corresponding objects. It is keyed according to the numbers +;;; themselves. + +;;; In order to make the hash and unhash tables weakly hold the +;;; objects hashed, the following mechanism is used: + +;;; The hash table, a vector, has a SNMV header before all the +;;; buckets, and therefore the garbage collector will skip it and will +;;; not relocate its buckets. It becomes invalid after a garbage +;;; collection and the first thing the daemon does is clear it. Each +;;; bucket is a normal alist with the objects in the cars, and the +;;; numbers in the cdrs, thus assq can be used to find an object in +;;; the bucket. + +;;; The unhash table, also a vector, holds the objects by means of +;;; weak conses. These weak conses are the same as the pairs in the +;;; buckets in the hash table, but with their type codes changed. +;;; Each of the buckets in the unhash table is headed by an extra pair +;;; whose car is usually #T. This pair is used by the splicing code. +;;; The daemon treats buckets headed by #F differently from buckets +;;; headed by #T. A bucket headed by #T is compressed: Those pairs +;;; whose cars have disappeared are spliced out from the bucket. On +;;; the other hand, buckets headed by #F are not compressed. The +;;; intent is that while object-unhash is traversing a bucket, the +;;; bucket is locked so that the daemon will not splice it out behind +;;; object-unhash's back. Then object-unhash does not need to be +;;; locked against garbage collection. + (define (hash x) - (if (eq? x #F) + (if (eq? x false) 0 (object-hash x))) - (define (unhash n) (if (zero? n) - #F + false (or (object-unhash n) (error "unhash: Not a valid hash number" n)))) (define (valid-hash-number? n) (if (zero? n) - #T + true (object-unhash n))) (define object-hash) @@ -116,128 +115,127 @@ (weak-cons-type (microcode-type 'WEAK-CONS)) (snmv-type (microcode-type 'MANIFEST-SPECIAL-NM-VECTOR)) (&make-object (make-primitive-procedure '&MAKE-OBJECT))) - (declare (compilable-primitive-functions &make-object)) + +(define next-hash-number) +(define hash-table-size) +(define unhash-table) +(define hash-table) + +(define (initialize-object-hash! size) + (set! next-hash-number 1) + (set! hash-table-size size) + (set! unhash-table (vector-cons size '())) + (set! hash-table (vector-cons (1+ size) '())) + (vector-set! hash-table 0 (&make-object snmv-type size)) + (let initialize ((n 0)) + (if (= n size) + true + (begin (vector-set! unhash-table n (cons true '())) + (initialize (1+ n)))))) - (define next-hash-number) - (define hash-table-size) - (define unhash-table) - (define hash-table) - - (define (initialize-object-hash! size) - (set! next-hash-number 1) - (set! hash-table-size size) - (set! unhash-table (vector-cons size '())) - (set! hash-table (vector-cons (1+ size) '())) - (vector-set! hash-table 0 (&make-object snmv-type size)) - (let initialize ((n 0)) - (if (= n size) - #T - (begin (vector-set! unhash-table n (cons #T '())) - (initialize (1+ n)))))) - - ;; This is not dangerous because assq is a primitive and does not - ;; cause consing. The rest of the consing (including that by the - ;; interpreter) is a small bounded amount. - - (set! object-hash - (named-lambda (object-hash object) - (with-interrupt-mask INTERRUPT-MASK-NONE - (lambda (ignore) - (let* ((hash-index (1+ (remainder (primitive-datum object) - hash-table-size))) - (bucket (vector-ref hash-table hash-index)) - (association (assq object bucket))) - (if (not (null? association)) - (cdr association) - (let ((pair (cons object next-hash-number)) - (result next-hash-number) - (unhash-bucket - (vector-ref unhash-table - (remainder next-hash-number - hash-table-size)))) - (set! next-hash-number (1+ next-hash-number)) - (vector-set! hash-table hash-index (cons pair bucket)) - (set-cdr! unhash-bucket - (cons (primitive-set-type weak-cons-type - pair) - (cdr unhash-bucket))) - result))))))) - - ;; This is safe because it locks the garbage collector out only for - ;; a little time, enough to tag the bucket being searched, so that - ;; the daemon will not splice that bucket. - - (set! object-unhash - (named-lambda (object-unhash number) - (let ((index (remainder number hash-table-size))) - (with-interrupt-mask INTERRUPT-MASK-NONE - (lambda (ie) - (let ((bucket (vector-ref unhash-table index))) - (set-car! bucket #F) - (let ((result - (with-interrupt-mask INTERRUPT-MASK-GC-OK - (lambda (ignore) - (let loop ((l (cdr bucket))) - (cond ((null? l) #F) - ((= number (system-pair-cdr (car l))) - (system-pair-car (car l))) - (else (loop (cdr l))))))))) - (set-car! bucket #T) - result))))))) +;;; This is not dangerous because assq is a primitive and does not +;;; cause consing. The rest of the consing (including that by the +;;; interpreter) is a small bounded amount. + +(set! object-hash +(named-lambda (object-hash object) + (with-interrupt-mask interrupt-mask-none + (lambda (ignore) + (let* ((hash-index (1+ (modulo (primitive-datum object) hash-table-size))) + (bucket (vector-ref hash-table hash-index)) + (association (assq object bucket))) + (if (not (null? association)) + (cdr association) + (let ((pair (cons object next-hash-number)) + (result next-hash-number) + (unhash-bucket + (vector-ref unhash-table + (modulo next-hash-number hash-table-size)))) + (set! next-hash-number (1+ next-hash-number)) + (vector-set! hash-table hash-index (cons pair bucket)) + (set-cdr! unhash-bucket + (cons (primitive-set-type weak-cons-type pair) + (cdr unhash-bucket))) + result))))))) + +;;; This is safe because it locks the garbage collector out only for a +;;; little time, enough to tag the bucket being searched, so that the +;;; daemon will not splice that bucket. + +(set! object-unhash +(named-lambda (object-unhash number) + (let ((index (modulo number hash-table-size))) + (with-interrupt-mask interrupt-mask-none + (lambda (ie) + (let ((bucket (vector-ref unhash-table index))) + (set-car! bucket false) + (let ((result + (with-interrupt-mask interrupt-mask-gc-ok + (lambda (ignore) + (let loop ((l (cdr bucket))) + (cond ((null? l) false) + ((= number (system-pair-cdr (car l))) + (system-pair-car (car l))) + (else (loop (cdr l))))))))) + (set-car! bucket true) + result))))))) ;;;; Rehash daemon - ;; The following is dangerous because of the (unnecessary) consing - ;; done by the interpreter while it executes the loops. It runs - ;; with interrupts turned off. The (necessary) consing done by - ;; rehash is not dangerous because at least that much storage was - ;; freed by the garbage collector. To understand this, notice that - ;; the hash table has a SNMV header, so the garbage collector does - ;; not trace the hash table buckets, therefore freeing their - ;; storage. The header is SNM rather than NM to make the buckets be - ;; relocated at band load/restore time. - - ;; Until this code is compiled, and therefore safe, it is replaced - ;; by a primitive. See the installation code below. - - #| - - (define (rehash weak-pair) - (let ((index (1+ (remainder - (primitive-datum (system-pair-car weak-pair)) - hash-table-size)))) - (vector-set! hash-table - index - (cons (primitive-set-type pair-type weak-pair) - (vector-ref hash-table index))))) - - (define (cleanup n) - (if (zero? n) - 'DONE - (begin (vector-set! hash-table n '()) - (cleanup (-1+ n))))) - - (define (rehash-gc-daemon) - (cleanup hash-table-size) - (let outer ((n (-1+ hash-table-size))) - (if (negative? n) - #T - (let ((bucket (vector-ref unhash-table n))) - (if (car bucket) - (let inner1 ((l1 bucket) (l2 (cdr bucket))) - (cond ((null? l2) (outer (-1+ n))) - ((eq? (system-pair-car (car l2)) #F) - (set-cdr! l1 (cdr l2)) - (inner1 l1 (cdr l1))) - (else (rehash (car l2)) - (inner1 l2 (cdr l2))))) - (let inner2 ((l (cdr bucket))) - (cond ((null? l) (outer (-1+ n))) - ((eq? (system-pair-car (car l)) #F) - (inner2 (cdr l))) - (else (rehash (car l)) - (inner2 (cdr l)))))))))) - - (add-gc-daemon! rehash-gc-daemon) - |# +;;; The following is dangerous because of the (unnecessary) consing +;;; done by the interpreter while it executes the loops. It runs with +;;; interrupts turned off. The (necessary) consing done by rehash is +;;; not dangerous because at least that much storage was freed by the +;;; garbage collector. To understand this, notice that the hash table +;;; has a SNMV header, so the garbage collector does not trace the +;;; hash table buckets, therefore freeing their storage. The header +;;; is SNM rather than NM to make the buckets be relocated at band +;;; load/restore time. + +;;; Until this code is compiled, and therefore safe, it is replaced by +;;; a primitive. See the installation code below. + +#| +(define (rehash weak-pair) + (let ((index (1+ (modulo (primitive-datum (system-pair-car weak-pair)) + hash-table-size)))) + (vector-set! hash-table + index + (cons (primitive-set-type pair-type weak-pair) + (vector-ref hash-table index))))) + +(define (cleanup n) + (if (zero? n) + 'DONE + (begin (vector-set! hash-table n '()) + (cleanup (-1+ n))))) + +(define (rehash-gc-daemon) + (cleanup hash-table-size) + (let outer ((n (-1+ hash-table-size))) + (if (negative? n) + true + (let ((bucket (vector-ref unhash-table n))) + (if (car bucket) + (let inner1 ((l1 bucket) (l2 (cdr bucket))) + (cond ((null? l2) (outer (-1+ n))) + ((eq? (system-pair-car (car l2)) false) + (set-cdr! l1 (cdr l2)) + (inner1 l1 (cdr l1))) + (else (rehash (car l2)) + (inner1 l2 (cdr l2))))) + (let inner2 ((l (cdr bucket))) + (cond ((null? l) (outer (-1+ n))) + ((eq? (system-pair-car (car l)) false) + (inner2 (cdr l))) + (else (rehash (car l)) + (inner2 (cdr l)))))))))) + +(add-gc-daemon! rehash-gc-daemon) +|# + +(add-gc-daemon! + (let ((primitive (make-primitive-procedure 'REHASH))) + (lambda () + (primitive unhash-table hash-table)))) -- 2.25.1