From 217f084e66c25ece625b9414e6c3018888ceae44 Mon Sep 17 00:00:00 2001 From: wlott <wlott> Date: Mon, 17 May 1993 21:22:23 +0000 Subject: [PATCH] Added weak hash table support. Added gengc support. --- code/hash.lisp | 516 ++++++++++++++++++++++++++++++++++++++++--------- 1 file changed, 421 insertions(+), 95 deletions(-) diff --git a/code/hash.lisp b/code/hash.lisp index 2fbdc9d4e..ca25e7077 100644 --- a/code/hash.lisp +++ b/code/hash.lisp @@ -7,7 +7,7 @@ ;;; Scott Fahlman or slisp-group@cs.cmu.edu. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/hash.lisp,v 1.22 1993/02/26 08:25:37 ram Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/hash.lisp,v 1.23 1993/05/17 21:22:23 wlott Exp $") ;;; ;;; ********************************************************************** ;;; @@ -21,7 +21,7 @@ gethash remhash maphash clrhash hash-table-count with-hash-table-iterator hash-table-rehash-size hash-table-rehash-threshold - hash-table-size hash-table-test + hash-table-size hash-table-test hash-table-weak-p sxhash)) (in-package :ext) @@ -30,8 +30,10 @@ (in-package :common-lisp) -;;;; The hash-table structure. +;;;; The hash-table structures. +;;; HASH-TABLE -- defstruct. +;;; (defstruct (hash-table (:constructor %make-hash-table) (:print-function %print-hash-table) @@ -67,7 +69,17 @@ (number-entries 0 :type index) ;; ;; Vector of ht-buckets. - (table (required-argument) :type simple-vector)) + (table (required-argument) :type simple-vector) + ;; + ;; True if this is a weak hash table, meaning that key->value mappings will + ;; disappear if there are no other references to the key. Note: this only + ;; matters if the hash function indicates that the hashing is EQ based. + (weak-p nil :type (member t nil)) + ;; + #+gengc + ;; Chain of buckets that need to be rehashed because their hashing is EQ + ;; based and the key has been moved by the garbage collector. + (needing-rehash nil :type (or null hash-table-bucket))) ;;; (defun %print-hash-table (ht stream depth) (declare (ignore depth) (stream stream)) @@ -82,20 +94,92 @@ `(integer 0 ,max-hash)) -(defstruct hash-table-bucket +(defstruct (hash-table-bucket + (:print-function %print-hash-table-bucket)) ;; ;; The hashing associated with key, kept around so we don't have to recompute - ;; it each time. When NIL, then just use %primitive make-fixnum. We don't - ;; cache the results of make-fixnum, because it can change with a GC. - (hash nil :type (or hash null)) + ;; it each time. In the non-gengc system, if this is NIL it means that the + ;; hashing is EQ based, so use the address of the value. If the gengc + ;; system, we use the presence of the scavhook to tell that. + #-gengc (hash nil :type (or hash null)) + #+gengc (hash 0 :type hash) ;; - ;; The key and value, originally supplied by the user. + ;; The key and value, originally supplied by the user. If the hash table + ;; is weak, and this is eq based, then the key is really a weak pointer to + ;; the key. (key nil :type t) (value nil :type t) ;; ;; The next bucket, or NIL if there are no more. (next nil :type (or hash-table-bucket null))) +;;; +(defun %print-hash-table-bucket (bucket stream depth) + (declare (ignore depth)) + (print-unreadable-object (bucket stream :type t) + (format stream "for ~S->~S~@[ ~D~]" + (hash-table-bucket-key bucket) + (hash-table-bucket-value bucket) + (hash-table-bucket-hash bucket)))) + +#+gengc +(defstruct (hash-table-eq-bucket + (:include hash-table-bucket)) + ;; + ;; The scavenger-hook object used to detect when the EQ hashing of key will + ;; change. Only NIL during creation. + (scavhook nil :type (or null scavenger-hook)) + ;; + ;; True iff this bucket is still linked into the corresponding hash table's + ;; vector. + (linked nil :type (member t nil))) + +#| + +;;; SCAN-STATE -- defstruct. +;;; +;;; Holds the state of a MAPHASH or WITH-HASH-TABLE-ITERATOR. +;;; +(defstruct (scan-state) + ;; + ;; The index into the hash-table-table. + (index 0 :type index) + ;; + ;; The current bucket in that chain. + (bucket nil :type (or null hash-table-bucket)) + ;; + ) + +;;; Non-gengc: +;;; +;;; %puthash: if there are any active scans, then make sure the current bucket +;;; for each scan holds the key we are trying to puthash, and flame out of it +;;; isn't. Given that we have our hands directly on the correct bucket, just +;;; go for it. +;;; +;;; remhash: make the same check as with %puthash. If it checks out, then +;;; just scan down the correct bucket chain and yank it. +;;; +;;; rehash: because of the above two tests, rehash will only be called by +;;; gethash. And we need to do the rehash in order to look anything up. So +;;; make a list of all the remaining buckets, and stick them in the scan-state. +;;; +;;; Gengc: +;;; +;;; %puthash & remhash: same as above. +;;; +;;; rehash: is only ever called by puthash, so doesn't need anything special to +;;; account for active scans. +;;; +;;; flush-needing-rehash: will only be called by gethash for the same reason +;;; rehash is only called by gethash in the non-gengc system. And basically +;;; needs to do the same thing rehash does in the non-gengc system. +;;; +;;; hash-table-scavenger-hook: needs to check to see if the bucket being +;;; unlinked is after the current bucket in any of the active scans. If so, +;;; it needs to add it to a list of buckets that will be processed after all +;;; the buckets visable in the hash-table-table have been delt with. +|# ;;;; Utility functions. @@ -161,7 +245,7 @@ ;;; MAKE-HASH-TABLE -- public. ;;; (defun make-hash-table (&key (test 'eql) (size 65) (rehash-size 1.5) - (rehash-threshold 1)) + (rehash-threshold 1) (weak-p nil)) "Creates and returns a new hash table. The keywords are as follows: :TEST -- Indicates what kind of test to use. Only EQ, EQL, and EQUAL are currently supported. @@ -174,9 +258,12 @@ :REHASH-THRESHOLD -- Indicates how dense the table can become before forcing a rehash. Can be any positive number <= to 1, with density approaching zero as the threshold approaches 0. Density 1 means an - average of one entry per bucket." - (declare (type (or function (member eq eql equal)) test) - (type index size)) + average of one entry per bucket. + CMUCL Extension: + :WEAK-P -- If T, don't keep entries if the key would otherwise be + garbage." + (declare (type (or function symbol) test) + (type index size) (type (member t nil) weak-p)) (let ((rehash-size (if (integerp rehash-size) rehash-size (float rehash-size 1.0))) @@ -210,7 +297,8 @@ :rehash-size rehash-size :rehash-threshold rehash-threshold :rehash-trigger (round (* (float length) rehash-threshold)) - :table vector))))) + :table vector + :weak-p weak-p))))) (defun hash-table-count (hash-table) "Returns the number of entries in the given HASH-TABLE." @@ -233,6 +321,10 @@ (setf (documentation 'hash-table-test 'function) "Return the test HASH-TABLE was created with.") +(setf (documentation 'hash-table-weak-p 'function) + "Return T if HASH-TABLE will not keep entries for keys that would + otherwise be garbage, and NIL if it will.") + ;;;; Accessing functions. @@ -254,7 +346,8 @@ (float (the index (round (* rehash-size old-length)))))) old-length)) - (new-vector (make-array new-length :initial-element nil))) + (new-vector (make-array new-length :initial-element nil)) + #-gengc (weak-p (hash-table-weak-p table))) (declare (type index new-length)) (dotimes (i old-length) (declare (type index i)) @@ -262,17 +355,28 @@ (next nil)) ((null bucket)) (setf next (hash-table-bucket-next bucket)) - (let* ((old-hashing (hash-table-bucket-hash bucket)) - (hashing (cond - (old-hashing old-hashing) - (t - (set-header-data new-vector - vm:vector-valid-hashing-subtype) - (pointer-hash (hash-table-bucket-key bucket))))) - (index (rem hashing new-length))) - (declare (type index hashing index)) - (setf (hash-table-bucket-next bucket) (svref new-vector index)) - (setf (svref new-vector index) bucket))) + (block deal-with-one-bucket + (let* ((hashing + #-gengc + (or (hash-table-bucket-hash bucket) + (let ((key (hash-table-bucket-key bucket))) + (set-header-data new-vector + vm:vector-valid-hashing-subtype) + (if weak-p + (multiple-value-bind + (real-key valid) + (weak-pointer-value key) + (cond (valid + (pointer-hash real-key)) + (t + (decf (hash-table-number-entries table)) + (return-from deal-with-one-bucket nil)))) + (pointer-hash key)))) + #+gengc (hash-table-bucket-hash bucket)) + (index (rem hashing new-length))) + (declare (type index hashing index)) + (setf (hash-table-bucket-next bucket) (svref new-vector index)) + (setf (svref new-vector index) bucket)))) ;; We clobber the old vector contents so that if it is living in ;; static space it won't keep ahold of pointers into dynamic space. (setf (svref old-vector i) nil)) @@ -283,6 +387,34 @@ (float new-length)))))) (undefined-value)) +#+gengc +(defun flush-needing-rehash (table) + (let* ((weak-p (hash-table-weak-p table)) + (vector (hash-table-table table)) + (length (length vector))) + (do ((bucket (hash-table-needing-rehash table) next) + (next nil)) + ((null bucket)) + (setf next (hash-table-bucket-next bucket)) + (flet ((relink-bucket (key) + (let* ((hashing (pointer-hash key)) + (index (rem hashing length))) + (setf (hash-table-bucket-hash bucket) hashing) + (setf (hash-table-bucket-next bucket) (svref vector index)) + (setf (svref vector index) bucket) + (setf (hash-table-eq-bucket-linked bucket) t)))) + (let ((key (hash-table-bucket-key bucket))) + (if weak-p + (multiple-value-bind + (real-key valid) + (weak-pointer-value key) + (if valid + (relink-bucket real-key) + (decf (hash-table-number-entries table)))) + (relink-bucket key)))))) + (setf (hash-table-needing-rehash table) nil) + (undefined-value)) + ;;; GETHASH -- Public. ;;; (defun gethash (key hash-table &optional default) @@ -292,23 +424,84 @@ (declare (type hash-table hash-table) (values t (member t nil))) (without-gcing + #-gengc (when (= (get-header-data (hash-table-table hash-table)) vm:vector-must-rehash-subtype) (rehash hash-table nil)) - (let* ((vector (hash-table-table hash-table)) - (length (length vector)) - (hashing (funcall (hash-table-hash-fun hash-table) key)) - (index (rem hashing length)) - (test-fun (hash-table-test-fun hash-table))) - (declare (type index hashing)) - (do ((bucket (svref vector index) (hash-table-bucket-next bucket))) - ((null bucket) (values default nil)) - (let ((bucket-hashing (hash-table-bucket-hash bucket))) - (when (if bucket-hashing - (and (= bucket-hashing hashing) - (funcall test-fun key (hash-table-bucket-key bucket))) - (eq key (hash-table-bucket-key bucket))) - (return (values (hash-table-bucket-value bucket) t)))))))) + #+gengc + (when (hash-table-needing-rehash hash-table) + (flush-needing-rehash hash-table)) + (multiple-value-bind + (hashing eq-based) + (funcall (hash-table-hash-fun hash-table) key) + (let* ((vector (hash-table-table hash-table)) + (length (length vector)) + (index (rem hashing length))) + (declare (type index hashing)) + (if eq-based + (if (hash-table-weak-p hash-table) + (do ((bucket (svref vector index) + (hash-table-bucket-next bucket))) + ((null bucket) (values default nil)) + (when #+gengc (hash-table-eq-bucket-p bucket) + #-gengc (null (hash-table-bucket-hash bucket)) + (multiple-value-bind + (bucket-key valid) + (weak-pointer-value (hash-table-bucket-key bucket)) + (assert valid) + (when (eq key bucket-key) + (return (values (hash-table-bucket-value bucket) + t)))))) + (do ((bucket (svref vector index) + (hash-table-bucket-next bucket))) + ((null bucket) (values default nil)) + (when (eq key (hash-table-bucket-key bucket)) + (return (values (hash-table-bucket-value bucket) t))))) + (do ((test-fun (hash-table-test-fun hash-table)) + (bucket (svref vector index) (hash-table-bucket-next bucket))) + ((null bucket) (values default nil)) + (let ((bucket-hashing (hash-table-bucket-hash bucket))) + (when (and #-gengc bucket-hashing + (= bucket-hashing hashing) + #+gengc (not (hash-table-eq-bucket-p bucket)) + (funcall test-fun key + (hash-table-bucket-key bucket))) + (return (values (hash-table-bucket-value bucket) t)))))))))) + + +#+gengc +(defun get-hash-table-scavenger-hook (hash-table bucket) + (declare (type hash-table hash-table) + (type hash-table-eq-bucket bucket)) + (flet ((hash-table-scavenger-hook () + (when (hash-table-eq-bucket-linked bucket) + (let* ((vector (hash-table-table hash-table)) + (length (length vector)) + (index (rem (hash-table-eq-bucket-hash bucket) length))) + (declare (type index index)) + (do ((prev nil next) + (next (svref vector index) (hash-table-bucket-next next))) + ((null next) + (warn "Couldn't find where ~S was linked inside ~S" + bucket hash-table)) + (when (eq next bucket) + (if prev + (setf (hash-table-bucket-next prev) + (hash-table-bucket-next bucket)) + (setf (svref vector index) + (hash-table-bucket-next bucket))) + (setf (hash-table-eq-bucket-linked bucket) nil) + (return))) + (if (and (hash-table-weak-p hash-table) + (not (nth-value 1 + (weak-pointer-value + (hash-table-bucket-key bucket))))) + (decf (hash-table-number-entries hash-table)) + (setf (hash-table-bucket-next bucket) + (hash-table-needing-rehash hash-table) + (hash-table-needing-rehash hash-table) + bucket)))))) + #'hash-table-scavenger-hook)) ;;; %PUTHASH -- public setf method. ;;; @@ -319,9 +512,13 @@ (setf (hash-table-number-entries hash-table) entries) (cond ((> entries (hash-table-rehash-trigger hash-table)) (rehash hash-table t)) + #-gengc ((= (get-header-data (hash-table-table hash-table)) vm:vector-must-rehash-subtype) (rehash hash-table nil)))) + #+gengc + (when (hash-table-needing-rehash hash-table) + (flush-needing-rehash hash-table)) (multiple-value-bind (hashing eq-based) (funcall (hash-table-hash-fun hash-table) key) @@ -329,28 +526,77 @@ (let* ((vector (hash-table-table hash-table)) (length (length vector)) (index (rem hashing length)) - (first-bucket (svref vector index)) - (test-fun (hash-table-test-fun hash-table))) + (first-bucket (svref vector index))) (declare (type index index)) - (do ((bucket first-bucket (hash-table-bucket-next bucket))) - ((null bucket) - (when eq-based - (set-header-data vector vm:vector-valid-hashing-subtype)) - (setf (svref vector index) - (make-hash-table-bucket - :hash (unless eq-based hashing) - :key key - :value value - :next first-bucket))) - (let ((bucket-hashing (hash-table-bucket-hash bucket))) - (when (if bucket-hashing - (and (= bucket-hashing hashing) - (funcall test-fun - key (hash-table-bucket-key bucket))) - (eq key (hash-table-bucket-key bucket))) - (setf (hash-table-bucket-value bucket) value) - (decf (hash-table-number-entries hash-table)) - (return))))))) + (block scan + (if eq-based + (if (hash-table-weak-p hash-table) + (do ((bucket first-bucket (hash-table-bucket-next bucket))) + ((null bucket)) + (when #+gengc (hash-table-eq-bucket-p bucket) + #-gengc (null (hash-table-bucket-hash bucket)) + (multiple-value-bind + (bucket-key valid) + (weak-pointer-value (hash-table-bucket-key bucket)) + (assert valid) + (when (eq key bucket-key) + (setf (hash-table-bucket-value bucket) value) + (decf (hash-table-number-entries hash-table)) + (return-from scan nil))))) + (do ((bucket first-bucket (hash-table-bucket-next bucket))) + ((null bucket)) + (when (eq key (hash-table-bucket-key bucket)) + (setf (hash-table-bucket-value bucket) value) + (decf (hash-table-number-entries hash-table)) + (return-from scan nil)))) + (do ((test-fun (hash-table-test-fun hash-table)) + (bucket first-bucket (hash-table-bucket-next bucket))) + ((null bucket)) + (let ((bucket-hashing (hash-table-bucket-hash bucket))) + (when (and #-gengc bucket-hashing + (= bucket-hashing hashing) + #+gengc (not (hash-table-eq-bucket-p bucket)) + (funcall test-fun + key + (hash-table-bucket-key bucket))) + (setf (hash-table-bucket-value bucket) value) + (decf (hash-table-number-entries hash-table)) + (return-from scan nil))))) + #-gengc + (when eq-based + (set-header-data vector vm:vector-valid-hashing-subtype)) + (setf (svref vector index) + #-gengc + (if eq-based + (make-hash-table-bucket + :hash nil + :key (make-weak-pointer key) + :value value + :next first-bucket) + (make-hash-table-bucket + :hash hashing + :key key + :value value + :next first-bucket)) + #+gengc + (if eq-based + (let ((bucket (make-hash-table-eq-bucket + :hash hashing + :key (make-weak-pointer key) + :value value + :next first-bucket + :linked t))) + (setf (hash-table-eq-bucket-scavhook bucket) + (make-scavenger-hook + :value key + :function (get-hash-table-scavenger-hook + hash-table bucket))) + bucket) + (make-hash-table-bucket + :hash hashing + :key key + :value value + :next first-bucket))))))) value) ;;; REMHASH -- public. @@ -361,30 +607,75 @@ (declare (type hash-table hash-table) (values (member t nil))) (without-gcing + #-gengc (when (= (get-header-data (hash-table-table hash-table)) vm:vector-must-rehash-subtype) (rehash hash-table nil)) - (let* ((vector (hash-table-table hash-table)) - (length (length vector)) - (hashing (funcall (hash-table-hash-fun hash-table) key)) - (index (rem hashing length)) - (test-fun (hash-table-test-fun hash-table))) - (declare (type index hashing index)) - (do ((prev nil bucket) - (bucket (svref vector index) (hash-table-bucket-next bucket))) - ((null bucket) nil) - (let ((bucket-hashing (hash-table-bucket-hash bucket))) - (when (if bucket-hashing - (and (= bucket-hashing hashing) - (funcall test-fun key (hash-table-bucket-key bucket))) - (eq key (hash-table-bucket-key bucket))) - (if prev - (setf (hash-table-bucket-next prev) - (hash-table-bucket-next bucket)) - (setf (svref vector index) - (hash-table-bucket-next bucket))) - (decf (hash-table-number-entries hash-table)) - (return t))))))) + #+gengc + (when (hash-table-needing-rehash hash-table) + (flush-needing-rehash hash-table)) + (multiple-value-bind + (hashing eq-based) + (funcall (hash-table-hash-fun hash-table) key) + (let* ((vector (hash-table-table hash-table)) + (length (length vector)) + (index (rem hashing length))) + (declare (type index hashing index)) + (if eq-based + (if (hash-table-weak-p hash-table) + (do ((prev nil bucket) + (bucket (svref vector index) + (hash-table-bucket-next bucket))) + ((null bucket) nil) + (when #+gengc (hash-table-eq-bucket-p bucket) + #-gengc (null (hash-table-bucket-hash bucket)) + (multiple-value-bind + (bucket-key valid) + (weak-pointer-value (hash-table-bucket-key bucket)) + (assert valid) + (when (eq key bucket-key) + #+gengc + (setf (hash-table-eq-bucket-linked bucket) nil) + (if prev + (setf (hash-table-bucket-next prev) + (hash-table-bucket-next bucket)) + (setf (svref vector index) + (hash-table-bucket-next bucket))) + (decf (hash-table-number-entries hash-table)) + (return t))))) + (do ((prev nil bucket) + (bucket (svref vector index) + (hash-table-bucket-next bucket))) + ((null bucket) nil) + (when (eq key (hash-table-bucket-key bucket)) + #+gengc + (setf (hash-table-eq-bucket-linked bucket) nil) + (if prev + (setf (hash-table-bucket-next prev) + (hash-table-bucket-next bucket)) + (setf (svref vector index) + (hash-table-bucket-next bucket))) + (decf (hash-table-number-entries hash-table)) + (return t)))) + (do ((test-fun (hash-table-test-fun hash-table)) + (prev nil bucket) + (bucket (svref vector index) + (hash-table-bucket-next bucket))) + ((null bucket) nil) + (let ((bucket-hashing (hash-table-bucket-hash bucket))) + (when (and #-gengc bucket-hashing + (= bucket-hashing hashing) + #+gengc (not (hash-table-eq-bucket-p bucket)) + (funcall test-fun key + (hash-table-bucket-key bucket))) + (if prev + (setf (hash-table-bucket-next prev) + (hash-table-bucket-next bucket)) + (setf (svref vector index) + (hash-table-bucket-next bucket))) + (decf (hash-table-number-entries hash-table)) + (return t))))))))) + ;;; CLRHASH -- public. ;;; @@ -393,8 +684,14 @@ itself." (let ((vector (hash-table-table hash-table))) (dotimes (i (length vector)) + #+gengc + (do ((bucket (aref vector i) (hash-table-bucket-next bucket))) + ((null bucket)) + (when (hash-table-eq-bucket-p bucket) + (setf (hash-table-eq-bucket-linked bucket) nil))) (setf (aref vector i) nil)) (setf (hash-table-number-entries hash-table) 0) + #-gengc (set-header-data vector vm:vector-normal-subtype)) hash-table) @@ -414,13 +711,30 @@ (symbol (symbol-function map-function)))) (vector (hash-table-table hash-table))) - (dotimes (i (length vector)) - (declare (type index i)) - (do ((bucket (svref vector i) (hash-table-bucket-next bucket))) - ((null bucket)) - (funcall fun - (hash-table-bucket-key bucket) - (hash-table-bucket-value bucket)))))) + (declare (type function fun)) + (if (hash-table-weak-p hash-table) + (dotimes (i (length vector)) + (declare (type index i)) + (do ((bucket (svref vector i) (hash-table-bucket-next bucket))) + ((null bucket)) + (if #-gengc (null (hash-table-bucket-hash bucket)) + #+gengc (hash-table-eq-bucket-p bucket) + (let ((weak-pointer (hash-table-bucket-key bucket))) + (multiple-value-bind + (key valid) + (weak-pointer-value weak-pointer) + (when valid + (funcall fun key (hash-table-bucket-value bucket))))) + (funcall fun + (hash-table-bucket-key bucket) + (hash-table-bucket-value bucket))))) + (dotimes (i (length vector)) + (declare (type index i)) + (do ((bucket (svref vector i) (hash-table-bucket-next bucket))) + ((null bucket)) + (funcall fun + (hash-table-bucket-key bucket) + (hash-table-bucket-value bucket))))))) (defmacro with-hash-table-iterator ((function hash-table) &body body) @@ -432,6 +746,7 @@ (let ((n-function (gensym "WITH-HASH-TABLE-ITERRATOR-"))) `(let ((,n-function (let* ((table ,hash-table) + (weak-p (hash-table-weak-p ,hash-table)) (vector (hash-table-table table)) (length (length vector)) (index 0) @@ -440,11 +755,23 @@ ((,function () (cond (bucket - (multiple-value-prog1 - (values t - (hash-table-bucket-key bucket) - (hash-table-bucket-value bucket)) - (setf bucket (hash-table-bucket-next bucket)))) + (let ((orig bucket)) + (setf bucket (hash-table-bucket-next orig)) + (if (and weak-p + #-gengc (null (hash-table-bucket-hash orig)) + #+gengc (hash-table-eq-bucket-p orig)) + (multiple-value-bind + (key valid) + (weak-pointer-value + (hash-table-bucket-key orig)) + (if valid + (values t + key + (hash-table-bucket-value orig)) + (,function))) + (values t + (hash-table-bucket-key orig) + (hash-table-bucket-value orig))))) ((= (incf index) length) (values nil)) (t @@ -561,7 +888,6 @@ ;; Everything else. (t 42))) - ;;;; Dumping one as a constant. -- GitLab