From e751d3f9b7465d9d19152fbb832c9f52e6c0d316 Mon Sep 17 00:00:00 2001
From: Taylor R Campbell <campbell@mumble.net>
Date: Fri, 13 Aug 2010 20:18:56 +0000
Subject: [PATCH] Rework the hash table entry abstraction.

This simplifies some of the code (at the expense of a longer
definition for the abstraction leading to a longer hashtb.scm
altogether), and makes it less prone to mistakes with using the
keys and data of entries without checking their validity -- which
will matter especially for hash tables with ephemeron entries when
those are implemented.

Check the results of the key hash table function.  Sprinkle some
guarantees throughout the code.  Disable type and range checks in
the hash table methods, where it is safe to do so.

With type and range checks still enabled, performance on strong eq
and eqv hash tables is no different from what it was last week.
Performance on weak hash tables is ever so slightly worse, but that
is because weak hash tables were incorrect before.

New tests check for some regressions.
---
 src/runtime/hashtb.scm            | 509 ++++++++++++++++++------------
 tests/runtime/test-hash-table.scm | 126 ++++++--
 2 files changed, 412 insertions(+), 223 deletions(-)

diff --git a/src/runtime/hashtb.scm b/src/runtime/hashtb.scm
index 73ee873eb..184d91e2e 100644
--- a/src/runtime/hashtb.scm
+++ b/src/runtime/hashtb.scm
@@ -26,6 +26,20 @@ USA.
 ;;;; Hash Tables
 ;;; package: (runtime hash-table)
 
+;;; Integration declarations are carefully placed in this file.  If you
+;;; change anything here, make sure that everything expands the way it
+;;; should.  In particular, the strong and weak entry accessors should
+;;; be completely open-coded in MAKE-STRONG-TYPE and MAKE-WEAK-TYPE, as
+;;; should the KEY-HASH and KEY=? procedures for strong and weak EQ and
+;;; EQV hash table types.  None of the hash table methods should cons
+;;; closures, and we rely on integration declarations, not just Liar's
+;;; cleverness, to guarantee this.
+;;;
+;;; Furthermore, before making any changes, enable type and range
+;;; checks in the two places they are disabled, and run through the
+;;; code and test cases to check that everything is safe before
+;;; disabling them again.
+
 (declare (usual-integrations))
 
 ;;;; Structures
@@ -137,6 +151,7 @@ USA.
 
 (define (hash-table/modify! table key procedure default)
   (guarantee-hash-table table 'HASH-TABLE/MODIFY!)
+  (guarantee-procedure-of-arity procedure 1 'HASH-TABLE/MODIFY!)
   ((table-type-method:modify! (table-type table)) table key procedure default))
 
 (define (hash-table/intern! table key get-datum)
@@ -166,11 +181,6 @@ USA.
   (for-each (lambda (p) (procedure (car p) (cdr p)))
 	    (hash-table->alist table)))
 
-(define (hash-table-fold table procedure initial-value)
-  (fold (lambda (p v) (procedure (car p) (cdr p) v))
-	initial-value
-	(hash-table->alist table)))
-
 (define (hash-table->alist table)
   (guarantee-hash-table table 'HASH-TABLE->ALIST)
   (%hash-table-fold table
@@ -256,6 +266,53 @@ USA.
       (set-table-count! table 0)
       (reset-table! table))))
 
+;;;; Entry abstraction
+
+(define-integrable (make-entry-type make valid? c-w-k c-w-k&d set-datum!)
+  (lambda (receiver)
+    (declare (integrate-operator receiver))
+    (receiver make valid? c-w-k c-w-k&d set-datum!)))
+
+(define-integrable (make-entry type key datum)
+  (type (lambda (make valid? c-w-k c-w-k&d set-datum!)
+	  (declare (integrate-operator make))
+	  (declare (ignore valid? c-w-k c-w-k&d set-datum!))
+	  (make key datum))))
+
+(define-integrable (entry-valid? type entry)
+  (type (lambda (make valid? c-w-k c-w-k&d set-datum!)
+	  (declare (integrate-operator valid?))
+	  (declare (ignore make c-w-k c-w-k&d set-datum!))
+	  (valid? entry))))
+
+;;; Rather than expose an ENTRY-KEY and an ENTRY-DATUM, this entry
+;;; abstraction has only aggregate operations that (1) fetch the key
+;;; (and datum), and (2) branch depending on whether the entry is
+;;; valid, guaranteeing that the key and datum will have been fetched
+;;; before the branch.  This prevents users of the entry abstraction
+;;; from mistakenly using the key or datum of a weak entry without
+;;; checking whether the entry is valid -- a bug present in previous
+;;; revisions of this file.  For strong entries, the branch is
+;;; integrated away into nothing.
+
+(define-integrable (call-with-entry-key type entry if-valid if-not-valid)
+  (type (lambda (make valid? c-w-k c-w-k&d set-datum!)
+	  (declare (integrate-operator c-w-k))
+	  (declare (ignore make valid? c-w-k&d set-datum!))
+	  (c-w-k entry if-valid if-not-valid))))
+
+(define-integrable (call-with-entry-key&datum type entry if-valid if-not-valid)
+  (type (lambda (make valid? c-w-k c-w-k&d set-datum!)
+	  (declare (integrate-operator c-w-k&d))
+	  (declare (ignore make valid? c-w-k set-datum!))
+	  (c-w-k&d entry if-valid if-not-valid))))
+
+(define-integrable (set-entry-datum! type entry object)
+  (type (lambda (make valid? c-w-k c-w-k&d set-datum!)
+	  (declare (integrate-operator set-datum!))
+	  (declare (ignore make valid? c-w-k c-w-k&d))
+	  (set-datum! entry object))))
+
 ;;;; Weak table type
 
 (define (weak-hash-table/constructor key-hash key=?
@@ -267,39 +324,34 @@ USA.
 				  rehash-after-gc?))))
 
 (define (make-weak-hash-table-type key-hash key=? rehash-after-gc?)
-  (if rehash-after-gc?
-      (make-weak-rehash-type key-hash key=?)
-      (make-weak-no-rehash-type key-hash key=?)))
-
-(define-integrable (make-weak-rehash-type key-hash key=?)
+  (guarantee-procedure-of-arity key-hash 2 'MAKE-WEAK-HASH-TABLE-TYPE)
+  (guarantee-procedure-of-arity key=? 2 'MAKE-WEAK-HASH-TABLE-TYPE)
+  (let ((key-hash (protected-key-hash key-hash)))
+    (if rehash-after-gc?
+	(make-weak-rehash-type key-hash key=?)
+	(make-weak-no-rehash-type key-hash key=?))))
+
+(define (make-weak-rehash-type key-hash key=?)
+  (declare (integrate-operator key-hash key=?))
   (make-weak-type key-hash key=? #t (compute-address-hash key-hash)))
 
-(define-integrable (make-weak-no-rehash-type key-hash key=?)
+(define (make-weak-no-rehash-type key-hash key=?)
+  (declare (integrate-operator key-hash key=?))
   (make-weak-type key-hash key=? #f (compute-non-address-hash key-hash)))
 
-(define-integrable (make-weak-type key-hash key=? rehash-after-gc?
-				   compute-hash!)
+(define (make-weak-type key-hash key=? rehash-after-gc? compute-hash!)
+  (declare (integrate rehash-after-gc?))
+  (declare (integrate-operator key-hash key=? compute-hash!))
+  (declare (no-type-checks) (no-range-checks))
   (make-table-type key-hash key=? rehash-after-gc?
-		   (make-method:get compute-hash! key=? %weak-entry-valid?
-				    %weak-entry-key %weak-entry-datum)
-		   (make-method:put! compute-hash! key=? %weak-make-entry
-				     %weak-entry-valid? %weak-entry-key
-				     %weak-set-entry-datum!)
-		   (make-method:modify! compute-hash! key=? %weak-make-entry
-					%weak-entry-valid? %weak-entry-key
-					%weak-entry-datum
-					%weak-set-entry-datum!)
-		   (make-method:remove! compute-hash! key=? %weak-entry-valid?
-					%weak-entry-key)
-		   (make-method:clean! %weak-entry-valid?)
-		   (make-method:rehash! key-hash %weak-entry-valid?
-					%weak-entry-key)
-		   (make-method:fold %weak-entry-valid? %weak-entry-key
-				     %weak-entry-datum)
-		   (make-method:copy-bucket %weak-entry-valid?
-					    %weak-make-entry
-					    %weak-entry-key
-					    %weak-entry-datum)))
+		   (make-method:get compute-hash! key=? weak-entry-type)
+		   (make-method:put! compute-hash! key=? weak-entry-type)
+		   (make-method:modify! compute-hash! key=? weak-entry-type)
+		   (make-method:remove! compute-hash! key=? weak-entry-type)
+		   (make-method:clean! weak-entry-type)
+		   (make-method:rehash! key-hash weak-entry-type)
+		   (make-method:fold weak-entry-type)
+		   (make-method:copy-bucket weak-entry-type)))
 
 (define-integrable (%weak-make-entry key datum)
   ;; Use an ordinary pair for objects that aren't pointers or that
@@ -317,43 +369,65 @@ USA.
 (define-integrable %weak-entry-key system-pair-car)
 (define-integrable %weak-entry-datum system-pair-cdr)
 (define-integrable %weak-set-entry-datum! system-pair-set-cdr!)
+
+(define-integrable (%call-with-weak-entry-key entry if-valid if-not-valid)
+  (let ((k (%weak-entry-key entry)))
+    ;** Do not integrate K!  It must be fetched and saved *before* we
+    ;** determine whether the entry is valid.
+    (if (or (pair? entry) k)
+	(if-valid k)
+	(if-not-valid))))
+
+(define-integrable (%call-with-weak-entry-key&datum entry if-valid if-not)
+  (let ((k (%weak-entry-key entry)))
+    ;** Do not integrate K!  It is OK to integrate D only because these
+    ;** are weak pairs, not ephemerons, so D is held strongly anyway.
+    (if (or (pair? entry) k)
+	(if-valid k (%weak-entry-datum entry))
+	(if-not))))
+
+(define-integrable weak-entry-type
+  (make-entry-type %weak-make-entry
+		   %weak-entry-valid?
+		   %call-with-weak-entry-key
+		   %call-with-weak-entry-key&datum
+		   %weak-set-entry-datum!))
 
-(define-integrable (make-method:clean! entry-valid?)
-  (lambda (table)
+(define-integrable (make-method:clean! entry-type)
+  (define (method:clean table)
     (let ((buckets (table-buckets table)))
       (let ((n-buckets (vector-length buckets)))
 	(do ((i 0 (fix:+ i 1)))
 	    ((not (fix:< i n-buckets)))
-	  (letrec
-	      ((scan-head
-		(lambda (p)
-		  (if (pair? p)
-		      (if (entry-valid? (car p))
-			  (begin
-			    (vector-set! buckets i p)
-			    (scan-tail (cdr p) p))
-			  (begin
-			    (decrement-table-count! table)
-			    (scan-head (cdr p))))
-		      (vector-set! buckets i p))))
-	       (scan-tail
-		(lambda (p q)
-		  (if (pair? p)
-		      (if (entry-valid? (car p))
-			  (scan-tail (cdr p) p)
-			  (begin
-			    (decrement-table-count! table)
-			    (let loop ((p (cdr p)))
-			      (if (pair? p)
-				  (if (entry-valid? (car p))
-				      (begin
-					(set-cdr! q p)
-					(scan-tail (cdr p) p))
-				      (begin
-					(decrement-table-count! table)
-					(loop (cdr p))))
-				  (set-cdr! q p)))))))))
-	    (scan-head (vector-ref buckets i))))))))
+	  (let ()
+	    (define (scan-head p)
+	      (if (pair? p)
+		  (if (entry-valid? entry-type (car p))
+		      (begin
+			(vector-set! buckets i p)
+			(scan-tail (cdr p) p))
+		      (begin
+			(decrement-table-count! table)
+			(scan-head (cdr p))))
+		  (vector-set! buckets i p)))
+	    (define (scan-tail p q)
+	      (if (pair? p)
+		  (if (entry-valid? entry-type (car p))
+		      (scan-tail (cdr p) p)
+		      (begin
+			(decrement-table-count! table)
+			(let loop ((p (cdr p)))
+			  (if (pair? p)
+			      (if (entry-valid? entry-type (car p))
+				  (begin
+				    (set-cdr! q p)
+				    (scan-tail (cdr p) p))
+				  (begin
+				    (decrement-table-count! table)
+				    (loop (cdr p))))
+			      (set-cdr! q p)))))))
+	    (scan-head (vector-ref buckets i)))))))
+  method:clean)
 
 ;;;; Strong table type
 
@@ -366,116 +440,127 @@ USA.
 				    rehash-after-gc?))))
 
 (define (make-strong-hash-table-type key-hash key=? rehash-after-gc?)
-  (if rehash-after-gc?
-      (make-strong-rehash-type key-hash key=?)
-      (make-strong-no-rehash-type key-hash key=?)))
-
-(define-integrable (make-strong-rehash-type key-hash key=?)
+  (guarantee-procedure-of-arity key-hash 2 'MAKE-STRONG-HASH-TABLE-TYPE)
+  (guarantee-procedure-of-arity key=? 2 'MAKE-STRONG-HASH-TABLE-TYPE)
+  (let ((key-hash (protected-key-hash key-hash)))
+    (if rehash-after-gc?
+	(make-strong-rehash-type key-hash key=?)
+	(make-strong-no-rehash-type key-hash key=?))))
+
+(define (make-strong-rehash-type key-hash key=?)
+  (declare (integrate-operator key-hash key=?))
   (make-strong-type key-hash key=? #t (compute-address-hash key-hash)))
 
-(define-integrable (make-strong-no-rehash-type key-hash key=?)
+(define (make-strong-no-rehash-type key-hash key=?)
+  (declare (integrate-operator key-hash key=?))
   (make-strong-type key-hash key=? #f (compute-non-address-hash key-hash)))
 
-(define-integrable (make-strong-type key-hash key=? rehash-after-gc?
-				     compute-hash!)
+(define (make-strong-type key-hash key=? rehash-after-gc? compute-hash!)
+  (declare (integrate rehash-after-gc?))
+  (declare (integrate-operator key-hash key=? compute-hash!))
+  (declare (no-type-checks) (no-range-checks))
   (make-table-type key-hash key=? rehash-after-gc?
-		   (make-method:get compute-hash! key=? %strong-entry-valid?
-				    %strong-entry-key %strong-entry-datum)
-		   (make-method:put! compute-hash! key=? %strong-make-entry
-				     %strong-entry-valid? %strong-entry-key
-				     %strong-set-entry-datum!)
-		   (make-method:modify! compute-hash! key=?
-					%strong-make-entry %strong-entry-valid?
-					%strong-entry-key %strong-entry-datum
-					%strong-set-entry-datum!)
-		   (make-method:remove! compute-hash! key=?
-					%strong-entry-valid? %strong-entry-key)
+		   (make-method:get compute-hash! key=? strong-entry-type)
+		   (make-method:put! compute-hash! key=? strong-entry-type)
+		   (make-method:modify! compute-hash! key=? strong-entry-type)
+		   (make-method:remove! compute-hash! key=? strong-entry-type)
 		   (lambda (table) table unspecific)
-		   (make-method:rehash! key-hash %strong-entry-valid?
-					%strong-entry-key)
-		   (make-method:fold %strong-entry-valid?
-				     %strong-entry-key
-				     %strong-entry-datum)
-		   (make-method:copy-bucket %strong-entry-valid?
-					    %strong-make-entry
-					    %strong-entry-key
-					    %strong-entry-datum)))
+		   (make-method:rehash! key-hash strong-entry-type)
+		   (make-method:fold strong-entry-type)
+		   (make-method:copy-bucket strong-entry-type)))
 
 (define-integrable %strong-make-entry cons)
 (define-integrable (%strong-entry-valid? entry) entry #t)
 (define-integrable %strong-entry-key car)
 (define-integrable %strong-entry-datum cdr)
 (define-integrable %strong-set-entry-datum! set-cdr!)
+
+(define-integrable (%call-with-strong-entry-key entry if-valid if-not-valid)
+  if-not-valid				;ignore
+  (if-valid (%strong-entry-key entry)))
+
+(define-integrable (%call-with-strong-entry-key&datum entry if-valid if-not)
+  if-not				;ignore
+  (if-valid (%strong-entry-key entry) (%strong-entry-datum entry)))
+
+(define-integrable strong-entry-type
+  (make-entry-type %strong-make-entry
+		   %strong-entry-valid?
+		   %call-with-strong-entry-key
+		   %call-with-strong-entry-key&datum
+		   %strong-set-entry-datum!))
 
 ;;;; Methods
 
-(define-integrable (make-method:get compute-hash! key=?
-				    entry-valid? entry-key entry-datum)
-  (lambda (table key default)
-    (let ((hash (compute-hash! table key)))
-      (let loop ((p (vector-ref (table-buckets table) hash)))
-	(if (pair? p)
-	    (let ((key* (entry-key (car p)))
-		  (datum (entry-datum (car p))))
-	      (if (and (entry-valid? (car p)) (key=? key* key))
-		  datum
-		  (loop (cdr p))))
-	    default)))))
-
-(define-integrable (make-method:put! compute-hash! key=? make-entry
-				     entry-valid? entry-key set-entry-datum!)
-  (lambda (table key datum)
+(define-integrable (make-method:get compute-hash! key=? entry-type)
+  (define (method:get table key default)
+    (let loop
+	((p (vector-ref (table-buckets table) (compute-hash! table key))))
+      (if (pair? p)
+	  (call-with-entry-key&datum entry-type (car p)
+	    (lambda (key* datum)
+	      (declare (integrate key* datum))
+	      (if (key=? key* key) datum (loop (cdr p))))
+	    (lambda () (loop (cdr p))))
+	  default)))
+  method:get)
+
+(define-integrable (make-method:put! compute-hash! key=? entry-type)
+  (define (method:put! table key datum)
     (let ((hash (compute-hash! table key)))
       (let loop ((p (vector-ref (table-buckets table) hash)) (q #f))
 	(if (pair? p)
-	    (if (let ((key* (entry-key (car p))))
-		  (and (entry-valid? (car p)) (key=? key* key)))
-		(set-entry-datum! (car p) datum)
+	    (if (call-with-entry-key entry-type (car p)
+		  (lambda (key*) (declare (integrate key*)) (key=? key* key))
+		  (lambda () #f))
+		(set-entry-datum! entry-type (car p) datum)
 		(loop (cdr p) p))
 	    (with-table-locked! table
 	      (lambda ()
-		(let ((r (cons (make-entry key datum) '())))
+		(let ((r (cons (make-entry entry-type key datum) '())))
 		  (if q
 		      (set-cdr! q r)
 		      (vector-set! (table-buckets table) hash r)))
 		(increment-table-count! table)
-		(maybe-grow-table! table))))))))
+		(maybe-grow-table! table)))))))
+  method:put!)
 
-(define-integrable (make-method:modify! compute-hash! key=? make-entry
-					entry-valid? entry-key entry-datum
-					set-entry-datum!)
-  (lambda (table key procedure default)
+(define-integrable (make-method:modify! compute-hash! key=? entry-type)
+  (define (method:modify! table key procedure default)
     (let ((hash (compute-hash! table key)))
       (let loop ((p (vector-ref (table-buckets table) hash)) (q #f))
 	(if (pair? p)
-	    (let ((key* (entry-key (car p)))
-		  (datum (entry-datum (car p))))
-	      (if (and (entry-valid? (car p)) (key=? key* key))
-		  (with-table-locked! table
-		    (lambda ()
-		      (let ((datum* (procedure datum)))
-			(set-entry-datum! (car p) datum*)
-			datum*)))
-		  (loop (cdr p) p)))
+	    (call-with-entry-key&datum entry-type (car p)
+	      (lambda (key* datum)
+		(declare (integrate key* datum))
+		(if (key=? key* key)
+		    (with-table-locked! table
+		      (lambda ()
+			(let ((datum* (procedure datum)))
+			  (set-entry-datum! entry-type (car p) datum*)
+			  datum*)))
+		    (loop (cdr p) p)))
+	      (lambda () (loop (cdr p) p)))
 	    (let ((datum (procedure default)))
 	      (with-table-locked! table
 		(lambda ()
-		  (let ((r (cons (make-entry key datum) '())))
+		  (let ((r (cons (make-entry entry-type key datum) '())))
 		    (if q
 			(set-cdr! q r)
 			(vector-set! (table-buckets table) hash r)))
 		  (increment-table-count! table)
 		  (maybe-grow-table! table)))
-	      datum))))))
+	      datum)))))
+  method:modify!)
 
-(define-integrable (make-method:remove! compute-hash! key=?
-					entry-valid? entry-key)
-  (lambda (table key)
+(define-integrable (make-method:remove! compute-hash! key=? entry-type)
+  (define (method:remove! table key)
     (let ((hash (compute-hash! table key)))
       (let loop ((p (vector-ref (table-buckets table) hash)) (q #f))
 	(if (pair? p)
-	    (if (let ((key* (entry-key (car p))))
-		  (and (entry-valid? (car p)) (key=? key* key)))
+	    (if (call-with-entry-key entry-type (car p)
+		  (lambda (key*) (declare (integrate key*)) (key=? key* key))
+		  (lambda () #f))
 		(with-table-locked! table
 		  (lambda ()
 		    (if q
@@ -483,24 +568,28 @@ USA.
 			(vector-set! (table-buckets table) hash (cdr p)))
 		    (decrement-table-count! table)
 		    (maybe-shrink-table! table)))
-		(loop (cdr p) p)))))))
+		(loop (cdr p) p))))))
+  method:remove!)
 
-(define-integrable (make-method:rehash! key-hash entry-valid? entry-key)
-  (lambda (table entries)
+(define-integrable (make-method:rehash! key-hash entry-type)
+  (define (method:rehash! table entries)
     (let ((buckets (table-buckets table)))
       (let ((n-buckets (vector-length buckets)))
 	(let loop ((p entries))
 	  (if (pair? p)
-	      (let ((key (entry-key (car p))) (q (cdr p)))
-		(if (entry-valid? (car p))
+	      (let ((q (cdr p)))
+		(call-with-entry-key entry-type (car p)
+		  (lambda (key)
+		    (declare (integrate key))
 		    (let ((hash (key-hash key n-buckets)))
 		      (set-cdr! p (vector-ref buckets hash))
-		      (vector-set! buckets hash p))
-		    (decrement-table-count! table))
-		(loop q))))))))
+		      (vector-set! buckets hash p)))
+		  (lambda () (decrement-table-count! table)))
+		(loop q)))))))
+  method:rehash!)
 
-(define-integrable (make-method:fold entry-valid? entry-key entry-datum)
-  (lambda (table procedure initial-value)
+(define-integrable (make-method:fold entry-type)
+  (define (method:fold table procedure initial-value)
     (let ((buckets (table-buckets table)))
       (let ((n-buckets (vector-length buckets)))
 	(let per-bucket ((i 0) (value initial-value))
@@ -508,37 +597,39 @@ USA.
 	      (let per-entry ((p (vector-ref buckets i)) (value value))
 		(if (pair? p)
 		    (per-entry (cdr p)
-			       (let ((key (entry-key (car p)))
-				     (datum (entry-datum (car p))))
-				 (if (entry-valid? (car p))
-				     (procedure key datum value)
-				     value)))
+			       (call-with-entry-key&datum entry-type (car p)
+				 (lambda (key datum)
+				   (declare (integrate key datum))
+				   (procedure key datum value))
+				 (lambda () value)))
 		    (per-bucket (fix:+ i 1) value)))
-	      value))))))
+	      value)))))
+  method:fold)
 
-(define-integrable (make-method:copy-bucket entry-valid? make-entry
-					    entry-key entry-datum)
-  (lambda (bucket)
+(define-integrable (make-method:copy-bucket entry-type)
+  (define (method:copy-bucket bucket)
     (let find-head ((p bucket))
       (if (pair? p)
-	  (let ((key (entry-key (car p)))
-		(datum (entry-datum (car p))))
-	    (if (entry-valid? (car p))
-		(let ((head (cons (make-entry key datum) '())))
-		  (let loop ((p (cdr p)) (previous head))
-		    (if (pair? p)
-			(loop (cdr p)
-			      (let ((key (entry-key (car p)))
-				    (datum (entry-datum (car p))))
-				(if (entry-valid? (car p))
-				    (let ((p*
-					   (cons (make-entry key datum) '())))
-				      (set-cdr! previous p*)
-				      p*)
-				    previous)))))
-		  head)
-		(find-head (cdr p))))
-	  p))))
+	  (call-with-entry-key&datum entry-type (car p)
+	    (lambda (key datum)
+	      (declare (integrate key datum))
+	      (let ((head (cons (make-entry entry-type key datum) '())))
+		(let loop ((p (cdr p)) (previous head))
+		  (if (pair? p)
+		      (loop (cdr p)
+			    (call-with-entry-key&datum entry-type (car p)
+			      (lambda (key datum)
+				(declare (integrate key datum))
+				(let ((p*
+				       (cons (make-entry entry-type key datum)
+					     '())))
+				  (set-cdr! previous p*)
+				  p*))
+			      (lambda () previous)))))
+		head))
+	    (lambda () (find-head (cdr p))))
+	  p)))
+  method:copy-bucket)
 
 ;;;; Resizing
 
@@ -664,13 +755,15 @@ USA.
 ;;; have to shrink the table due to keys which have been reclaimed by
 ;;; the garbage collector.  REHASH-TABLE! explicitly checks for this
 ;;; possibility, and rehashes the table again if necessary.
-
+
 (define-integrable (compute-non-address-hash key-hash)
   (lambda (table key)
+    (declare (integrate table key))
     (key-hash key (vector-length (table-buckets table)))))
 
 (define-integrable (compute-address-hash key-hash)
   (lambda (table key)
+    (declare (integrate table key))
     (let loop ()
       (let ((hash (key-hash key (vector-length (table-buckets table)))))
 	(if (table-needs-rehash? table)
@@ -679,6 +772,18 @@ USA.
 	      (loop))
 	    hash)))))
 
+(define (protected-key-hash key-hash)
+  (lambda (key modulus)
+    (let ((hash (key-hash key modulus)))
+      (guarantee-hash hash modulus)
+      hash)))
+
+(define-integrable (guarantee-hash object limit)
+  (if (not (fixnum? object))
+      (error:wrong-type-datum object "index integer"))
+  (if (not (and (fix:<= 0 object) (fix:< object limit)))
+      (error:datum-out-of-range object)))
+
 (define (rehash-table! table)
   (with-table-locked! table
     (lambda ()
@@ -710,6 +815,7 @@ USA.
 	 ((ucode-primitive primitive-object-set-type)
 	  (ucode-type positive-fixnum)
 	  object)))
+    (declare (integrate n))		;Let the RTL CSE take care of it.
     (if (fix:< n 0)
 	(fix:not n)
 	n)))
@@ -787,12 +893,8 @@ USA.
 
 (define (make-hash-table #!optional key=? key-hash initial-size)
   (%make-hash-table (custom-table-type
-		     (if (default-object? key=?)
-			 equal?
-			 key=?)
-		     (if (default-object? key-hash)
-			 equal-hash-mod
-			 key-hash))
+		     (if (default-object? key=?) equal? key=?)
+		     (if (default-object? key-hash) equal-hash-mod key-hash))
 		    initial-size))
 
 (define (custom-table-type key=? key-hash)
@@ -818,13 +920,10 @@ USA.
 		  (eq? key-hash string-hash)
 		  (eq? key-hash hash)
 		  (eq? key-hash string-ci-hash)))
-	 ;; This LET avoids copying the IF in the integrated body of
-	 ;; MAKE-STRONG-NO-REHASH-TYPE, which does no good.
-	 (let ((key-hash
-		(if (eq? key-hash string-hash)
-		    string-hash-mod
-		    key-hash)))
-	   (make-strong-no-rehash-type key-hash key=?)))
+	 (make-strong-no-rehash-type (if (eq? key-hash string-hash)
+					 string-hash-mod
+					 key-hash)
+				     key=?))
 	(else
 	 (make-strong-rehash-type key-hash key=?))))
 
@@ -893,6 +992,11 @@ USA.
 			  (hash-table/put! table1 key datum))
 			unspecific))
   table1)
+
+(define (hash-table-fold table procedure initial-value)
+  (fold (lambda (p v) (procedure (car p) (cdr p) v))
+	initial-value
+	(hash-table->alist table)))
 
 ;;;; Miscellany
 
@@ -915,30 +1019,29 @@ USA.
 (define (initialize-package!)
   (set! address-hash-tables '())
   (add-primitive-gc-daemon! mark-address-hash-tables!)
-  (set! weak-eq-hash-table-type
-	(make-weak-rehash-type eq-hash-mod eq?))
-  (set! strong-eq-hash-table-type
-	(make-strong-rehash-type eq-hash-mod eq?))
-  (set! weak-eqv-hash-table-type
-	(make-weak-rehash-type eqv-hash-mod eqv?))
-  (set! strong-eqv-hash-table-type
-	(make-strong-rehash-type eqv-hash-mod eqv?))
-  (set! equal-hash-table-type
-	(make-strong-rehash-type equal-hash-mod equal?))
+  (let ()
+    (declare (integrate-operator make-weak-rehash-type))
+    (declare (integrate-operator make-weak-no-rehash-type))
+    (declare (integrate-operator make-weak-type))
+    (declare (integrate-operator make-strong-rehash-type))
+    (declare (integrate-operator make-strong-no-rehash-type))
+    (declare (integrate-operator make-strong-type))
+    (set! weak-eq-hash-table-type (make-weak-rehash-type eq-hash-mod eq?))
+    (set! strong-eq-hash-table-type (make-strong-rehash-type eq-hash-mod eq?))
+    (set! weak-eqv-hash-table-type (make-weak-rehash-type eqv-hash-mod eqv?))
+    (set! strong-eqv-hash-table-type
+	  (make-strong-rehash-type eqv-hash-mod eqv?)))
+  (set! equal-hash-table-type (make-strong-rehash-type equal-hash-mod equal?))
   (set! string-hash-table-type
 	(make-strong-no-rehash-type string-hash-mod string=?))
-  (set! make-weak-eq-hash-table
-	(hash-table-constructor eq-hash-table-type))
+  (set! make-weak-eq-hash-table (hash-table-constructor eq-hash-table-type))
   (set! make-strong-eq-hash-table
 	(hash-table-constructor strong-eq-hash-table-type))
-  (set! make-weak-eqv-hash-table
-	(hash-table-constructor eqv-hash-table-type))
+  (set! make-weak-eqv-hash-table (hash-table-constructor eqv-hash-table-type))
   (set! make-strong-eqv-hash-table
 	(hash-table-constructor strong-eqv-hash-table-type))
-  (set! make-equal-hash-table
-	(hash-table-constructor equal-hash-table-type))
-  (set! make-string-hash-table
-	(hash-table-constructor string-hash-table-type))
+  (set! make-equal-hash-table (hash-table-constructor equal-hash-table-type))
+  (set! make-string-hash-table (hash-table-constructor string-hash-table-type))
   unspecific)
 
 (define (mark-address-hash-tables!)
diff --git a/tests/runtime/test-hash-table.scm b/tests/runtime/test-hash-table.scm
index 89b5666cb..3895a078a 100644
--- a/tests/runtime/test-hash-table.scm
+++ b/tests/runtime/test-hash-table.scm
@@ -2,7 +2,7 @@
 
 Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
     1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
-    2006, 2007, 2008, 2009 Massachusetts Institute of Technology
+    2006, 2007, 2008, 2009, 2010 Massachusetts Institute of Technology
 
 This file is part of MIT/GNU Scheme.
 
@@ -113,12 +113,25 @@ USA.
    (lambda (table key datum) table key datum unspecific)
    (lambda (table key) table key unspecific)
    (lambda (table key default) table key default unspecific)
-   (lambda (table) table unspecific)))
+   (lambda (table) table '())))
 
+(load-option 'RB-TREE)
+
+(define (make-pointer-tree)
+  (make-rb-tree (lambda (x y) (fix:= (car x) (car y)))
+		(lambda (x y) (fix:< (car x) (car y)))))
+
+(define rbt
+  (make-implementation make-pointer-tree
+		       rb-tree/insert!
+		       rb-tree/delete!
+		       rb-tree/lookup
+		       rb-tree->alist))
+
 (load-option 'HASH-TABLE)
 
-(define htq
-  (make-implementation make-eq-hash-table
+(define shtq
+  (make-implementation make-strong-eq-hash-table
 		       hash-table/put!
 		       hash-table/remove!
 		       hash-table/get
@@ -126,8 +139,8 @@ USA.
 			 (sort (hash-table->alist table)
 			       (lambda (x y) (fix:< (caar x) (caar y)))))))
 
-(define htv
-  (make-implementation make-eqv-hash-table
+(define shtv
+  (make-implementation make-strong-eqv-hash-table
 		       hash-table/put!
 		       hash-table/remove!
 		       hash-table/get
@@ -135,8 +148,8 @@ USA.
 			 (sort (hash-table->alist table)
 			       (lambda (x y) (fix:< (caar x) (caar y)))))))
 
-(define ht
-  (make-implementation make-equal-hash-table
+(define whtq
+  (make-implementation make-weak-eq-hash-table
 		       hash-table/put!
 		       hash-table/remove!
 		       hash-table/get
@@ -144,18 +157,23 @@ USA.
 			 (sort (hash-table->alist table)
 			       (lambda (x y) (fix:< (caar x) (caar y)))))))
 
-(load-option 'RB-TREE)
-
-(define (make-pointer-tree)
-  (make-rb-tree (lambda (x y) (fix:= (car x) (car y)))
-		(lambda (x y) (fix:< (car x) (car y)))))
+(define whtv
+  (make-implementation make-weak-eqv-hash-table
+		       hash-table/put!
+		       hash-table/remove!
+		       hash-table/get
+		       (lambda (table)
+			 (sort (hash-table->alist table)
+			       (lambda (x y) (fix:< (caar x) (caar y)))))))
 
-(define rbt
-  (make-implementation make-pointer-tree
-		       rb-tree/insert!
-		       rb-tree/delete!
-		       rb-tree/lookup
-		       rb-tree->alist))
+(define ht
+  (make-implementation make-equal-hash-table
+		       hash-table/put!
+		       hash-table/remove!
+		       hash-table/get
+		       (lambda (table)
+			 (sort (hash-table->alist table)
+			       (lambda (x y) (fix:< (caar x) (caar y)))))))
 
 (define (test-correctness s implementation)
   (let ((table ((implementation/make implementation)))
@@ -189,4 +207,72 @@ USA.
 	    (if (not (and (eq? (caar alist) (caar check))
 			  (eq? (cdar alist) (cdar check))))
 		(error "Alist element incorrect:" (car alist) (car check)))
-	    (loop (cdr alist) (cdr check)))))))
\ No newline at end of file
+	    (loop (cdr alist) (cdr check)))))))
+
+(define (check implementation)
+  (let ((n #x1000))
+    (do ((i 0 (+ i 1))) ((= i #x100))
+      (let* ((key-radix (+ 1 (random-integer n)))
+	     (insert-fraction (random-real))
+	     (delete-fraction (- 1 insert-fraction)))
+	(test-correctness
+	 (make-sequence n key-radix insert-fraction delete-fraction)
+	 implementation)))))
+
+(define-test 'CHECK-AGAINST-RB-TREE
+  (lambda ()
+    (define (sub-test name implementation)
+      name				;What to do?
+      (run-sub-test (lambda () (check implementation))))
+    (sub-test 'STRONG-EQ-HASH-TABLE shtq)
+    (sub-test 'STRONG-EQV-HASH-TABLE shtv)
+    (sub-test 'WEAK-EQ-HASH-TABLE whtq)
+    (sub-test 'WEAK-EQV-HASH-TABLE whtv)
+    (sub-test 'EQUAL-HASH-TABLE ht)))
+
+;;; These are carefully tailored to the internal representation of
+;;; the hash table.  This is simpler, but less robust, than writing a
+;;; big, hairy, complicated statistical test that guarantees the
+;;; desired behaviour with high probability.
+
+(define-test 'REGRESSION:FALSE-KEY-OF-BROKEN-WEAK-ENTRY
+  (lambda ()
+    (let ((hash-table
+	   ((weak-hash-table/constructor (lambda (k m) k m 0) eqv?))))
+      (hash-table/put! hash-table (cons 0 0) 'LOSE)
+      (gc-flip)
+      (assert-eqv (hash-table/get hash-table #f 'WIN) 'WIN))))
+
+(define-test 'REGRESSION:MODIFICATION-DURING-SRFI-69-UPDATE
+  (lambda ()
+    (let ((hash-table
+	   ((strong-hash-table/constructor (lambda (k m) k m 0) eqv?))))
+      (hash-table/put! hash-table 0 'LOSE-0)
+      (hash-table-update! hash-table 0
+	(lambda (datum)
+	  datum				;ignore
+	  ;; Force consing a new entry.
+	  (hash-table/remove! hash-table 0)
+	  (hash-table/put! hash-table 0 'LOSE-1)
+	  'WIN))
+      (assert-eqv (hash-table/get hash-table 0 'LOSE-2) 'WIN))))
+
+(define-test 'REGRESSION:MODIFICATION-DURING-SRFI-69-FOLD
+  (lambda ()
+    (let* ((index 1)
+	   (hash-table
+	    ((strong-hash-table/constructor (lambda (k m) k m index)
+					    eqv?
+					    #t))))
+      (hash-table/put! hash-table 0 0)
+      (hash-table/put! hash-table 1 1)
+      (assert-eqv (hash-table-fold hash-table
+				   (lambda (key datum count)
+				     key datum ;ignore
+				     (set! index 0)
+				     ;; Force a rehash.
+				     (gc-flip)
+				     (hash-table/get hash-table 0 #f)
+				     (+ count 1))
+				   0)
+		  2))))
\ No newline at end of file
-- 
2.25.1