From: Taylor R Campbell <campbell@mumble.net>
Date: Sun, 29 Aug 2010 17:28:53 +0000 (+0000)
Subject: Extend hash table entry types to support ephemeral hash tables.
X-Git-Tag: 20101212-Gtk~77
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=a5e7841fdf715eeadde26e2e21261ec0e5c34ea8;p=mit-scheme.git

Extend hash table entry types to support ephemeral hash tables.

Add some tests for correctness against red/black trees.

Still missing are tests for weak and ephemeral entries types.
---

diff --git a/src/runtime/hashtb.scm b/src/runtime/hashtb.scm
index 184d91e2e..fe6b4fa8a 100644
--- a/src/runtime/hashtb.scm
+++ b/src/runtime/hashtb.scm
@@ -26,27 +26,13 @@ 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
 
 (define-structure (hash-table-type
 		   (type-descriptor <hash-table-type>)
-		   (constructor make-table-type)
+		   (constructor %make-table-type)
 		   (conc-name table-type-))
   (key-hash #f read-only #t)
   (key=? #f read-only #t)
@@ -312,209 +298,338 @@ USA.
 	  (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=?
-				     #!optional rehash-after-gc?)
-  (hash-table-constructor
-   (make-weak-hash-table-type key-hash key=?
-			      (if (default-object? rehash-after-gc?)
-				  #f
-				  rehash-after-gc?))))
-
-(define (make-weak-hash-table-type key-hash key=? rehash-after-gc?)
-  (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 (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 (make-weak-type key-hash key=? rehash-after-gc? compute-hash!)
+(define (make-table-type key-hash key=? rehash-after-gc? compute-hash!
+			 entry-type)
   (declare (integrate rehash-after-gc?))
-  (declare (integrate-operator key-hash key=? compute-hash!))
+  (declare (integrate-operator key-hash key=? compute-hash! entry-type))
   (declare (no-type-checks) (no-range-checks))
-  (make-table-type key-hash key=? rehash-after-gc?
-		   (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)
+  (%make-table-type key-hash key=? rehash-after-gc?
+		    (make-method:get compute-hash! key=? entry-type)
+		    (make-method:put! compute-hash! key=? entry-type)
+		    (make-method:modify! compute-hash! key=? entry-type)
+		    (make-method:remove! compute-hash! key=? entry-type)
+		    (if (eq? entry-type hash-table-entry-type:strong)
+			(named-lambda (method:no-clean! table)
+			  (declare (ignore table))
+			  unspecific)
+			(make-method:clean! entry-type))
+		    (make-method:rehash! key-hash entry-type)
+		    (make-method:fold entry-type)
+		    (make-method:copy-bucket entry-type)))
+
+(define-integrable (non-weak? object)
   ;; Use an ordinary pair for objects that aren't pointers or that
   ;; have unbounded extent.
-  (if (or (object-non-pointer? key)
-	  (number? key)
-	  (interned-symbol? key))
-      (cons key datum)
-      (system-pair-cons (ucode-type weak-cons) key datum)))
+  (or (object-non-pointer? object)
+      (number? object)
+      (interned-symbol? object)))
+
+(define-integrable (maybe-weak-cons a d)
+  (if (non-weak? a)
+      (cons a d)
+      (system-pair-cons (ucode-type WEAK-CONS) a d)))
+
+;;;; Entries of various flavours
+
+;;; Strong
+
+(define-integrable make-strong-entry cons)
+(define-integrable (strong-entry-valid? entry) entry #t)
+(define-integrable strong-entry-key car)
+(define-integrable strong-entry-datum cdr)
+(define-integrable set-strong-entry-datum! set-cdr!)
+
+(define-integrable (call-with-strong-entry-key entry if-valid if-not-valid)
+  (declare (ignore if-not-valid))
+  (if-valid (strong-entry-key entry) (lambda () unspecific)))
+
+(define-integrable (call-with-strong-entry-key&datum entry if-valid if-not)
+  (declare (ignore if-not))
+  (if-valid (strong-entry-key entry)
+	    (strong-entry-datum entry)
+	    (lambda () unspecific)))
 
-(define-integrable (%weak-entry-valid? entry)
+(declare (integrate-operator hash-table-entry-type:strong))
+(define hash-table-entry-type:strong
+  (make-entry-type make-strong-entry
+		   strong-entry-valid?
+		   call-with-strong-entry-key
+		   call-with-strong-entry-key&datum
+		   set-strong-entry-datum!))
+
+;;; Key-weak -- if the key is GC'd, the entry is dropped, but the datum
+;;; may be retained arbitrarily long.
+
+(define-integrable (make-key-weak-entry key datum)
+  (maybe-weak-cons key datum))
+
+(define-integrable (key-weak-entry-valid? entry)
   (or (pair? entry)
       (system-pair-car entry)))
 
-(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 key-weak-entry-key system-pair-car)
+(define-integrable key-weak-entry-datum system-pair-cdr)
+(define-integrable set-key-weak-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)))
+(define-integrable (call-with-key-weak-entry-key entry if-valid if-not-valid)
+  (let ((k (key-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-valid k (lambda () (reference-barrier k)))
 	(if-not-valid))))
 
-(define-integrable (%call-with-weak-entry-key&datum entry if-valid if-not)
-  (let ((k (%weak-entry-key entry)))
+(define-integrable (call-with-key-weak-entry-key&datum entry if-valid if-not)
+  (let ((k (key-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.
+    ;** are weak pairs, not ephemerons, so the entry holds D strongly
+    ;** anyway.
     (if (or (pair? entry) k)
-	(if-valid k (%weak-entry-datum entry))
+	(if-valid k
+		  (key-weak-entry-datum entry)
+		  (lambda () (reference-barrier k)))
 	(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!))
+(declare (integrate-operator hash-table-entry-type:key-weak))
+(define hash-table-entry-type:key-weak
+  (make-entry-type make-key-weak-entry
+		   key-weak-entry-valid?
+		   call-with-key-weak-entry-key
+		   call-with-key-weak-entry-key&datum
+		   set-key-weak-entry-datum!))
 
-(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)))
-	  (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)
+;;; Datum-weak -- if the datum is GC'd, the entry is dropped, but the
+;;; key may be retained arbitrarily long.
+
+(define-integrable (make-datum-weak-entry key datum)
+  (maybe-weak-cons datum key))
+
+(define-integrable (datum-weak-entry-valid? entry)
+  (or (pair? entry)
+      (system-pair-car entry)))
+
+(define-integrable datum-weak-entry-key system-pair-cdr)
+(define-integrable datum-weak-entry-datum system-pair-car)
+(define-integrable set-datum-weak-entry-datum! system-pair-set-car!)
+
+(define-integrable (call-with-datum-weak-entry-key entry if-valid if-not)
+  (let ((d (datum-weak-entry-datum entry)))
+    (if (or (pair? entry) d)
+	(if-valid (datum-weak-entry-key entry)
+		  (lambda () (reference-barrier d)))
+	(if-not))))
+
+(define-integrable (call-with-datum-weak-entry-key&datum entry if-valid if-not)
+  (let ((d (datum-weak-entry-datum entry)))
+    (if (or (pair? entry) d)
+	(if-valid (datum-weak-entry-key entry)
+		  d
+		  (lambda () (reference-barrier d)))
+	(if-not))))
+
+(declare (integrate-operator hash-table-entry-type:datum-weak))
+(define hash-table-entry-type:datum-weak
+  (make-entry-type make-datum-weak-entry
+		   datum-weak-entry-valid?
+		   call-with-datum-weak-entry-key
+		   call-with-datum-weak-entry-key&datum
+		   set-datum-weak-entry-datum!))
+
+;;; Key-or-datum-weak -- if either is GC'd, the entry is dropped.
+
+(define-integrable (make-key/datum-weak-entry key datum)
+  (maybe-weak-cons key (maybe-weak-cons datum '())))
+
+(define-integrable (key/datum-weak-entry-valid? entry)
+  (and (system-pair-car entry)
+       (system-pair-car (system-pair-cdr entry))))
+
+(define-integrable key/datum-weak-entry-key system-pair-car)
+(define-integrable (key/datum-weak-entry-datum entry)
+  (system-pair-car (system-pair-cdr entry)))
+
+(define-integrable (set-key/datum-weak-entry-datum! entry object)
+  (system-pair-set-car! (system-pair-cdr entry) object))
+
+(define-integrable (call-with-key/datum-weak-entry-key entry if-valid if-not)
+  (call-with-key/datum-weak-entry-key&datum entry
+    (lambda (k d barrier) d (if-valid k barrier))
+    if-not))
+
+(define-integrable (call-with-key/datum-weak-entry-key&datum entry
+		     if-valid
+		     if-not)
+  (let ((k (key/datum-weak-entry-key entry))
+	(d (key/datum-weak-entry-datum entry)))
+    (if (and (or (pair? entry) k)
+	     (or (pair? (system-pair-cdr entry))
+		 d))
+	(if-valid k d (lambda () (reference-barrier k) (reference-barrier d)))
+	(if-not))))
+
+(declare (integrate-operator hash-table-entry-type:key/datum-weak))
+(define hash-table-entry-type:key/datum-weak
+  (make-entry-type make-key/datum-weak-entry
+		   key/datum-weak-entry-valid?
+		   call-with-key/datum-weak-entry-key
+		   call-with-key/datum-weak-entry-key&datum
+		   set-key/datum-weak-entry-datum!))
 
-;;;; Strong table type
+;;; Key-ephemeral -- if the key is GC'd, the entry is dropped.
 
-(define (strong-hash-table/constructor key-hash key=?
-				       #!optional rehash-after-gc?)
-  (hash-table-constructor
-   (make-strong-hash-table-type key-hash key=?
-				(if (default-object? rehash-after-gc?)
-				    #f
-				    rehash-after-gc?))))
-
-(define (make-strong-hash-table-type key-hash key=? rehash-after-gc?)
-  (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 (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 (make-strong-type key-hash key=? rehash-after-gc? compute-hash!)
-  (declare (integrate rehash-after-gc?))
-  (declare (integrate-operator key-hash key=? compute-hash!))
+(define-integrable make-key-ephemeral-entry make-ephemeron)
+
+(define-integrable (key-ephemeral-entry-valid? entry)
+  (not (ephemeron-broken? entry)))
+
+(define-integrable key-ephemeral-entry-key ephemeron-key)
+(define-integrable key-ephemeral-entry-datum ephemeron-datum)
+(define-integrable set-key-ephemeral-entry-datum! set-ephemeron-datum!)
+
+(define-integrable (call-with-key-ephemeral-entry-key entry if-valid if-not)
+  (let ((k (key-ephemeral-entry-key entry)))
+    (if (key-ephemeral-entry-valid? entry)
+	(if-valid k (lambda () (reference-barrier k)))
+	(if-not))))
+
+(define-integrable (call-with-key-ephemeral-entry-key&datum entry
+		     if-valid
+		     if-not)
+  (let ((k (key-ephemeral-entry-key entry))
+	(d (key-ephemeral-entry-datum entry)))
+    ;** Do not integrate K or D here.  It is tempting to integrate D,
+    ;** but if the caller ignores the barrier, and its last reference
+    ;** to K precedes any reference to D, then the entry may be broken
+    ;** before we read the datum.
+    (if (key-ephemeral-entry-valid? entry)
+	(if-valid k d (lambda () (reference-barrier k)))
+	(if-not))))
+
+(declare (integrate-operator hash-table-entry-type:key-ephemeral))
+(define hash-table-entry-type:key-ephemeral
+  (make-entry-type make-key-ephemeral-entry
+		   key-ephemeral-entry-valid?
+		   call-with-key-ephemeral-entry-key
+		   call-with-key-ephemeral-entry-key&datum
+		   set-key-ephemeral-entry-datum!))
+
+;;; Datum-ephemeral -- if the datum is GC'd, the entry is dropped
+
+(define-integrable (make-datum-ephemeral-entry key datum)
+  (make-ephemeron datum key))
+
+(define-integrable (datum-ephemeral-entry-valid? entry)
+  (not (ephemeron-broken? entry)))
+
+(define-integrable datum-ephemeral-entry-key ephemeron-datum)
+(define-integrable datum-ephemeral-entry-datum ephemeron-key)
+(define-integrable set-datum-ephemeral-entry-datum! set-ephemeron-key!)
+
+(define-integrable (call-with-datum-ephemeral-entry-key entry if-valid if-not)
+  (call-with-datum-ephemeral-entry-key&datum entry
+    (lambda (k d barrier) d (if-valid k barrier))
+    if-not))
+
+(define-integrable (call-with-datum-ephemeral-entry-key&datum entry
+		     if-valid
+		     if-not)
+  (let ((k (datum-ephemeral-entry-key entry))
+	(d (datum-ephemeral-entry-datum entry)))
+    (if (datum-ephemeral-entry-valid? entry)
+	(if-valid k d (lambda () (reference-barrier d)))
+	(if-not))))
+
+(declare (integrate-operator hash-table-entry-type:datum-ephemeral))
+(define hash-table-entry-type:datum-ephemeral
+  (make-entry-type make-datum-ephemeral-entry
+		   datum-ephemeral-entry-valid?
+		   call-with-datum-ephemeral-entry-key
+		   call-with-datum-ephemeral-entry-key&datum
+		   set-datum-ephemeral-entry-datum!))
+
+;;; Key-and-datum-ephemeral -- the entry is dropped iff both key and
+;;; datum are GC'd.
+
+(define (make-key&datum-ephemeral-entry key datum)
+  (cons (make-ephemeron key datum) (make-ephemeron datum key)))
+
+(define-integrable (key&datum-ephemeral-entry-valid? entry)
+  (not (ephemeron-broken? (car entry))))
+
+(define-integrable (key&datum-ephemeral-entry-key entry)
+  (ephemeron-key (car entry)))
+
+(define-integrable (key&datum-ephemeral-entry-datum entry)
+  (ephemeron-datum (car entry)))
+
+(define (set-key&datum-ephemeral-entry-datum! entry object)
   (declare (no-type-checks) (no-range-checks))
-  (make-table-type key-hash key=? rehash-after-gc?
-		   (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-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!))
+  ;; Careful!  Don't use this with interrupts enabled, or it won't be
+  ;; atomic.
+  (set-ephemeron-datum! (car entry) object)
+  (set-ephemeron-key! (cdr entry) object))
+
+(define-integrable (call-with-key&datum-ephemeral-entry-key entry
+		     if-valid
+		     if-not)
+  (let ((k (key&datum-ephemeral-entry-key entry)))
+    (if (key&datum-ephemeral-entry-valid? entry)
+	(if-valid k (lambda () (reference-barrier k)))
+	(if-not))))
+
+(define-integrable (call-with-key&datum-ephemeral-entry-key&datum entry
+		     if-valid
+		     if-not)
+  (let ((k (key&datum-ephemeral-entry-key entry))
+	(d (key&datum-ephemeral-entry-datum entry)))
+    (if (key&datum-ephemeral-entry-valid? entry)
+	;; The reference barrier need use only K (or only D), because
+	;; as long as the entry and one of the key or datum is live,
+	;; the other of the key or datum will be live too.
+	(if-valid k d (lambda () (reference-barrier k)))
+	(if-not))))
+
+(declare (integrate-operator hash-table-entry-type:key&datum-ephemeral))
+(define hash-table-entry-type:key&datum-ephemeral
+  (make-entry-type make-key&datum-ephemeral-entry
+		   key&datum-ephemeral-entry-valid?
+		   call-with-key&datum-ephemeral-entry-key
+		   call-with-key&datum-ephemeral-entry-key&datum
+		   set-key&datum-ephemeral-entry-datum!))
 
 ;;;; Methods
 
-(define-integrable (make-method:get compute-hash! key=? entry-type)
+(define (make-method:get compute-hash! key=? entry-type)
+  (declare (integrate-operator 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)))
+    (let ((hash (compute-hash! table key)))
+      ;; Call COMPUTE-HASH! before TABLE-BUCKETS, because computing the
+      ;; hash might trigger rehashing which replaces the bucket vector.
+      (let loop ((p (vector-ref (table-buckets table) hash)))
+	(if (pair? p)
+	    (call-with-entry-key&datum entry-type (car p)
+	      (lambda (key* datum barrier)
+		(declare (integrate key* datum) (ignore barrier))
+		(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 (make-method:put! compute-hash! key=? entry-type)
+  (declare (integrate-operator 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 (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))
+	    (call-with-entry-key entry-type (car p)
+	      (lambda (key* barrier)
+		(declare (integrate key* barrier))
+		(if (key=? key* key)
+		    (begin (set-entry-datum! entry-type (car p) datum)
+			   (barrier))
+		    (loop (cdr p) p)))
+	      (lambda () (loop (cdr p) p)))
 	    (with-table-locked! table
 	      (lambda ()
 		(let ((r (cons (make-entry entry-type key datum) '())))
@@ -525,19 +640,21 @@ USA.
 		(maybe-grow-table! table)))))))
   method:put!)
 
-(define-integrable (make-method:modify! compute-hash! key=? entry-type)
+(define (make-method:modify! compute-hash! key=? entry-type)
+  (declare (integrate-operator 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)
 	    (call-with-entry-key&datum entry-type (car p)
-	      (lambda (key* datum)
-		(declare (integrate key* datum))
+	      (lambda (key* datum barrier)
+		(declare (integrate key* datum barrier))
 		(if (key=? key* key)
 		    (with-table-locked! table
 		      (lambda ()
 			(let ((datum* (procedure datum)))
 			  (set-entry-datum! entry-type (car p) datum*)
+			  (barrier)
 			  datum*)))
 		    (loop (cdr p) p)))
 	      (lambda () (loop (cdr p) p)))
@@ -553,25 +670,66 @@ USA.
 	      datum)))))
   method:modify!)
 
-(define-integrable (make-method:remove! compute-hash! key=? entry-type)
+(define (make-method:remove! compute-hash! key=? entry-type)
+  (declare (integrate-operator 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 (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
-			(set-cdr! q (cdr p))
-			(vector-set! (table-buckets table) hash (cdr p)))
-		    (decrement-table-count! table)
-		    (maybe-shrink-table! table)))
-		(loop (cdr p) p))))))
+	    (call-with-entry-key entry-type (car p)
+	      (lambda (key* barrier)
+		(declare (integrate key*) (ignore barrier))
+		(if (key=? key* key)
+		    (with-table-locked! table
+		      (lambda ()
+			(if q
+			    (set-cdr! q (cdr p))
+			    (vector-set! (table-buckets table) hash (cdr p)))
+			(decrement-table-count! table)
+			(maybe-shrink-table! table)))
+		    (loop (cdr p) p)))
+	      (lambda () (loop (cdr p) p)))))))
   method:remove!)
 
-(define-integrable (make-method:rehash! key-hash entry-type)
+(define (make-method:clean! entry-type)
+  (declare (integrate-operator 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)))
+	  (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!)
+
+(define (make-method:rehash! key-hash entry-type)
+  (declare (integrate-operator key-hash entry-type))
   (define (method:rehash! table entries)
     (let ((buckets (table-buckets table)))
       (let ((n-buckets (vector-length buckets)))
@@ -579,8 +737,8 @@ USA.
 	  (if (pair? p)
 	      (let ((q (cdr p)))
 		(call-with-entry-key entry-type (car p)
-		  (lambda (key)
-		    (declare (integrate key))
+		  (lambda (key barrier)
+		    (declare (integrate key) (ignore barrier))
 		    (let ((hash (key-hash key n-buckets)))
 		      (set-cdr! p (vector-ref buckets hash))
 		      (vector-set! buckets hash p)))
@@ -588,7 +746,8 @@ USA.
 		(loop q)))))))
   method:rehash!)
 
-(define-integrable (make-method:fold entry-type)
+(define (make-method:fold entry-type)
+  (declare (integrate-operator entry-type))
   (define (method:fold table procedure initial-value)
     (let ((buckets (table-buckets table)))
       (let ((n-buckets (vector-length buckets)))
@@ -598,28 +757,31 @@ USA.
 		(if (pair? p)
 		    (per-entry (cdr p)
 			       (call-with-entry-key&datum entry-type (car p)
-				 (lambda (key datum)
+				 (lambda (key datum barrier)
 				   (declare (integrate key datum))
+				   (declare (ignore barrier))
 				   (procedure key datum value))
 				 (lambda () value)))
 		    (per-bucket (fix:+ i 1) value)))
 	      value)))))
   method:fold)
 
-(define-integrable (make-method:copy-bucket entry-type)
+(define (make-method:copy-bucket entry-type)
+  (declare (integrate-operator entry-type))
   (define (method:copy-bucket bucket)
     (let find-head ((p bucket))
       (if (pair? p)
 	  (call-with-entry-key&datum entry-type (car p)
-	    (lambda (key datum)
-	      (declare (integrate key datum))
+	    (lambda (key datum barrier)
+	      (declare (integrate key datum) (ignore barrier))
 	      (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)
+			      (lambda (key datum barrier)
 				(declare (integrate key datum))
+				(declare (ignore barrier))
 				(let ((p*
 				       (cons (make-entry entry-type key datum)
 					     '())))
@@ -756,12 +918,14 @@ USA.
 ;;; 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)
+(define (compute-non-address-hash key-hash)
+  (declare (integrate-operator key-hash))
   (lambda (table key)
     (declare (integrate table key))
     (key-hash key (vector-length (table-buckets table)))))
 
-(define-integrable (compute-address-hash key-hash)
+(define (compute-address-hash key-hash)
+  (declare (integrate-operator key-hash))
   (lambda (table key)
     (declare (integrate table key))
     (let loop ()
@@ -803,11 +967,9 @@ USA.
 			     entries)))
 	  ((not (fix:< i n-buckets)) entries)))))
 
-;;;; EQ/EQV/EQUAL types
+;;;; EQ/EQV/EQUAL Hashing
 
-(declare (integrate eq-hash-mod))
-(define (eq-hash-mod key modulus)
-  (declare (integrate key modulus))
+(define-integrable (eq-hash-mod key modulus)
   (fix:remainder (eq-hash key) modulus))
 
 (define-integrable (eq-hash object)
@@ -820,9 +982,7 @@ USA.
 	(fix:not n)
 	n)))
 
-(declare (integrate eqv-hash-mod))
 (define-integrable (eqv-hash-mod key modulus)
-  (declare (integrate key modulus))
   (int:remainder (eqv-hash key) modulus))
 
 (define (eqv-hash key)
@@ -832,9 +992,7 @@ USA.
 	((%recnum? key) (%recnum->nonneg-int key))
 	(else (eq-hash key))))
 
-(declare (integrate equal-hash-mod))
 (define-integrable (equal-hash-mod key modulus)
-  (declare (integrate key modulus))
   (int:remainder (equal-hash key) modulus))
 
 (define (equal-hash key)
@@ -889,7 +1047,186 @@ USA.
 (define (int:abs n)
   (if (int:negative? n) (int:negate n) n))
 
-;;;; SRFI-69 compatability
+;;;; Constructing and Open-Coding Types and Constructors
+
+(define (make-hash-table* key-hash key=? rehash-after-gc? entry-type
+			  #!optional initial-size)
+  ((hash-table/constructor key-hash key=? rehash-after-gc? entry-type)
+   initial-size))
+
+(define (hash-table/constructor key-hash key=? rehash-after-gc? entry-type)
+  (hash-table-constructor
+   (make-hash-table-type key-hash key=? rehash-after-gc? entry-type)))
+
+(define (make-hash-table-type key-hash key=? rehash-after-gc? entry-type)
+  (hash-table/intern! (follow-memo-crap key-hash key=? rehash-after-gc?)
+		      entry-type
+    (lambda ()
+      (let ((constructor
+	     (hash-table/get hash-table-type-constructors entry-type #f)))
+	(if constructor
+	    (constructor key-hash key=? rehash-after-gc?)
+	    (%make-hash-table-type key-hash key=? rehash-after-gc?
+				   entry-type))))))
+
+(define (memoize-hash-table-type! key-hash key=? rehash-after-gc? entry-type
+				  type)
+  (let ((crap (follow-memo-crap key-hash key=? rehash-after-gc?)))
+    (cond ((hash-table/get crap entry-type #f)
+	   => (lambda (type*)
+		(warn "Replacing memoized hash table type:" type type*))))
+    (hash-table/put! crap entry-type type)))
+
+(define (follow-memo-crap key-hash key=? rehash-after-gc?)
+  (define (intern-car! pair generator)
+    (or (car pair) (let ((v (generator))) (set-car! pair v) v)))
+  (define (intern-cdr! pair generator)
+    (or (cdr pair) (let ((v (generator))) (set-cdr! pair v) v)))
+  ((if rehash-after-gc? intern-car! intern-cdr!)
+   (hash-table/intern!
+    (hash-table/intern! memoized-hash-table-types
+			key-hash
+			make-key-ephemeral-eq-hash-table)
+    key=?
+    (lambda () (cons #f #f)))
+   make-key-ephemeral-eq-hash-table))
+
+(define (%make-hash-table-type key-hash key=? rehash-after-gc? entry-type)
+  (let ((compute-hash!
+	 ((if rehash-after-gc?
+	      compute-address-hash
+	      compute-non-address-hash)
+	  (protected-key-hash key-hash))))
+    ;; Don't integrate COMPUTE-HASH!.
+    (make-table-type key-hash key=? rehash-after-gc? compute-hash!
+		     entry-type)))
+
+(define-integrable (open-type-constructor entry-type)
+  (declare (integrate-operator %make-hash-table-type make-table-type))
+  (declare (integrate-operator make-method:get make-method:put!))
+  (declare (integrate-operator make-method:modify! make-method:remove!))
+  (declare (integrate-operator make-method:clean! make-method:rehash!))
+  (declare (integrate-operator make-method:fold make-method:copy-bucket))
+  (lambda (key-hash key=? rehash-after-gc?)
+    (let ((compute-hash!
+	   ((if rehash-after-gc?
+		compute-address-hash
+		compute-non-address-hash)
+	    (protected-key-hash key-hash))))
+      ;; Don't integrate COMPUTE-HASH!.
+      (make-table-type key-hash key=? rehash-after-gc? compute-hash!
+		       entry-type))))
+
+(define-integrable (open-type-constructor! entry-type)
+  (hash-table/put! hash-table-type-constructors
+		   entry-type
+		   (open-type-constructor entry-type)))
+
+(define-integrable (open-type key-hash key=? rehash-after-gc? entry-type)
+  (declare (integrate-operator %make-hash-table-type make-table-type))
+  (declare (integrate-operator compute-address-hash compute-non-address-hash))
+  (declare (integrate-operator make-method:get make-method:put!))
+  (declare (integrate-operator make-method:modify! make-method:remove!))
+  (declare (integrate-operator make-method:clean! make-method:rehash!))
+  (declare (integrate-operator make-method:fold make-method:copy-bucket))
+  (make-table-type key-hash key=? rehash-after-gc?
+		   (if rehash-after-gc?
+		       (compute-address-hash key-hash)
+		       (compute-non-address-hash key-hash))
+		   entry-type))
+
+(define-integrable (open-type! key-hash key=? rehash-after-gc? entry-type)
+  (let ((hash-table-type
+	 (open-type key-hash key=? rehash-after-gc? entry-type)))
+    (memoize-hash-table-type! key-hash key=? rehash-after-gc? entry-type
+			      hash-table-type)
+    hash-table-type))
+
+(define equal-hash-table-type)
+(define key-ephemeral-eq-hash-table-type)
+(define key-weak-eq-hash-table-type)
+(define key-weak-eqv-hash-table-type)
+(define string-hash-table-type)
+(define strong-eq-hash-table-type)
+(define strong-eqv-hash-table-type)
+
+(define hash-table-type-constructors)
+(define memoized-hash-table-types)
+
+(define (initialize-memoized-hash-table-types!)
+  (set! key-ephemeral-eq-hash-table-type
+	(open-type eq-hash-mod eq? #t hash-table-entry-type:key-ephemeral))
+  (set! make-key-ephemeral-eq-hash-table
+	(hash-table-constructor key-ephemeral-eq-hash-table-type))
+  (set! hash-table-type-constructors (make-key-ephemeral-eq-hash-table))
+  (set! memoized-hash-table-types (make-key-ephemeral-eq-hash-table))
+  (memoize-hash-table-type! eq-hash-mod eq? #t
+			    hash-table-entry-type:key-ephemeral
+			    key-ephemeral-eq-hash-table-type)
+  (open-type-constructor! hash-table-entry-type:strong)
+  (open-type-constructor! hash-table-entry-type:key-weak)
+  (open-type-constructor! hash-table-entry-type:datum-weak)
+  (open-type-constructor! hash-table-entry-type:key/datum-weak)
+  (open-type-constructor! hash-table-entry-type:key-ephemeral)
+  (open-type-constructor! hash-table-entry-type:datum-ephemeral)
+  (open-type-constructor! hash-table-entry-type:key&datum-ephemeral)
+  (let ((make make-hash-table-type))	;For brevity...
+    (set! equal-hash-table-type
+	  (make equal-hash-mod equal? #t hash-table-entry-type:strong))
+    (set! key-weak-eq-hash-table-type	;Open-coded
+	  (open-type! eq-hash-mod eq? #t hash-table-entry-type:key-weak))
+    (set! key-weak-eqv-hash-table-type
+	  (make eqv-hash-mod eqv? #t hash-table-entry-type:key-weak))
+    (set! string-hash-table-type
+	  (make string-hash-mod string=? #t hash-table-entry-type:strong))
+    (set! strong-eq-hash-table-type	;Open-coded
+	  (open-type! eq-hash-mod eq? #t hash-table-entry-type:strong))
+    (set! strong-eqv-hash-table-type
+	  (make eqv-hash-mod eqv? #t hash-table-entry-type:strong)))
+  unspecific)
+
+(define make-equal-hash-table)
+(define make-key-ephemeral-eq-hash-table)
+(define make-key-weak-eq-hash-table)
+(define make-key-weak-eqv-hash-table)
+(define make-string-hash-table)
+(define make-strong-eq-hash-table)
+(define make-strong-eqv-hash-table)
+
+(define (initialize-hash-table-type-constructors!)
+  (let-syntax ((init
+		(syntax-rules ()
+		  ((INIT constructor type)
+		   (SET! constructor (HASH-TABLE-CONSTRUCTOR type))))))
+    (init make-equal-hash-table equal-hash-table-type)
+    ;; This is done above.
+    ;; (init make-key-ephemeral-eq-hash-table key-ephemeral-eq-hash-table-type)
+    (init make-key-weak-eq-hash-table key-weak-eq-hash-table-type)
+    (init make-key-weak-eqv-hash-table key-weak-eqv-hash-table-type)
+    (init make-string-hash-table string-hash-table-type)
+    (init make-strong-eq-hash-table strong-eq-hash-table-type)
+    (init make-strong-eqv-hash-table strong-eqv-hash-table-type))
+  unspecific)
+
+;;;; Compatibility with SRFI 69 and older MIT Scheme
+
+(define (strong-hash-table/constructor key-hash key=?
+				       #!optional rehash-after-gc?)
+  (hash-table/constructor key-hash
+			  key=?
+			  (if (default-object? rehash-after-gc?)
+			      #f
+			      rehash-after-gc?)
+			  hash-table-entry-type:strong))
+
+(define (weak-hash-table/constructor key-hash key=?
+				     #!optional rehash-after-gc?)
+  (hash-table/constructor key-hash
+			  key=?
+			  (if (default-object? rehash-after-gc?)
+			      #f
+			      rehash-after-gc?)
+			  hash-table-entry-type:key-weak))
 
 (define (make-hash-table #!optional key=? key-hash initial-size)
   (%make-hash-table (custom-table-type
@@ -898,34 +1235,17 @@ USA.
 		    initial-size))
 
 (define (custom-table-type key=? key-hash)
-  (cond ((and (eq? key=? eq?)
-	      (or (eq? key-hash eq-hash-mod)
-		  (eq? key-hash hash-by-identity)))
-	 strong-eq-hash-table-type)
-	((and (eq? key=? eqv?)
-	      (eq? key-hash eqv-hash-mod))
-	 strong-eqv-hash-table-type)
-	((and (eq? key=? equal?)
-	      (or (eq? key-hash equal-hash-mod)
-		  (eq? key-hash hash)))
-	 equal-hash-table-type)
-	((and (eq? key=? string=?)
-	      (or (eq? key-hash string-hash-mod)
-		  (eq? key-hash string-hash)
-		  (eq? key-hash hash)))
-	 string-hash-table-type)
-	((and (or (eq? key=? string=?)
-		  (eq? key=? string-ci=?))
-	      (or (eq? key-hash string-hash-mod)
-		  (eq? key-hash string-hash)
-		  (eq? key-hash hash)
-		  (eq? key-hash string-ci-hash)))
-	 (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=?))))
+  (make-hash-table-type key-hash
+			key=?
+			(if (and (or (eq? key=? string=?)
+				     (eq? key=? string-ci=?))
+				 (or (eq? key-hash string-hash-mod)
+				     (eq? key-hash string-hash)
+				     (eq? key-hash hash)
+				     (eq? key-hash string-ci-hash)))
+			    #f		;No rehash needed after GC
+			    #t)		;Rehash needed after GC
+			hash-table-entry-type:strong))
 
 (define (alist->hash-table alist #!optional key=? key-hash)
   (guarantee-alist alist 'ALIST->HASH-TABLE)
@@ -1002,46 +1322,9 @@ USA.
 
 (define address-hash-tables)
 
-(define weak-eq-hash-table-type)
-(define strong-eq-hash-table-type)
-(define weak-eqv-hash-table-type)
-(define strong-eqv-hash-table-type)
-(define equal-hash-table-type)
-(define string-hash-table-type)
-
-(define make-weak-eq-hash-table)
-(define make-strong-eq-hash-table)
-(define make-weak-eqv-hash-table)
-(define make-strong-eqv-hash-table)
-(define make-equal-hash-table)
-(define make-string-hash-table)
-
-(define (initialize-package!)
+(define (initialize-address-hash-tables!)
   (set! address-hash-tables '())
   (add-primitive-gc-daemon! mark-address-hash-tables!)
-  (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-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-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))
   unspecific)
 
 (define (mark-address-hash-tables!)
@@ -1063,11 +1346,19 @@ USA.
 	(else (error:wrong-type-argument object description procedure))))
 
 (define-integrable (with-table-locked! table thunk)
-  table
+  (declare (ignore table))
   (let ((interrupt-mask (set-interrupt-enables! interrupt-mask/gc-ok)))
     (let ((value (thunk)))
       (set-interrupt-enables! interrupt-mask)
       value)))
 
 (define default-marker
-  (list 'DEFAULT-MARKER))
\ No newline at end of file
+  (list 'DEFAULT-MARKER))
+
+(define (initialize-package!)
+  ;; Must come before any address hash tables are created.
+  (initialize-address-hash-tables!)
+  ;; Must come before any hash table types are constructed or used.
+  ;; This constructs an address hash table, however.
+  (initialize-memoized-hash-table-types!)
+  (initialize-hash-table-type-constructors!))
\ No newline at end of file
diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index d98dc2b9f..43ab5365f 100644
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -1957,8 +1957,8 @@ USA.
   (files "hashtb")
   (parent (runtime))
   (export ()
-	  (eq-hash-table-type weak-eq-hash-table-type)
-	  (eqv-hash-table-type weak-eqv-hash-table-type)
+	  (eq-hash-table-type key-weak-eq-hash-table-type)
+	  (eqv-hash-table-type key-weak-eqv-hash-table-type)
 	  (hash-table-delete! hash-table/remove!)
 	  (hash-table-equivalence-function hash-table/key=?)
 	  (hash-table-hash-function hash-table/key-hash)
@@ -1969,10 +1969,14 @@ USA.
 	  (hash-table-update!/default hash-table/modify!)
 	  (hash-table-values hash-table/datum-list)
 	  (hash-table-walk hash-table/for-each)
-	  (make-eq-hash-table make-weak-eq-hash-table)
-	  (make-eqv-hash-table make-weak-eqv-hash-table)
-	  (make-object-hash-table make-weak-eqv-hash-table)
-	  (make-symbol-hash-table make-weak-eq-hash-table)
+	  (make-eq-hash-table make-key-weak-eq-hash-table)
+	  (make-eqv-hash-table make-key-weak-eqv-hash-table)
+	  (make-object-hash-table make-key-weak-eqv-hash-table)
+	  (make-symbol-hash-table make-strong-eq-hash-table)
+	  (make-weak-eq-hash-table make-key-weak-eq-hash-table)
+	  (make-weak-eqv-hash-table make-key-weak-eqv-hash-table)
+	  (weak-eq-hash-table-type key-weak-eq-hash-table-type)
+	  (weak-eqv-hash-table-type key-weak-eqv-hash-table-type)
 	  alist->hash-table
 	  eq-hash
 	  eq-hash-mod
@@ -1986,6 +1990,13 @@ USA.
 	  hash-by-identity
 	  hash-table->alist
 	  hash-table-copy
+	  hash-table-entry-type:datum-ephemeral
+	  hash-table-entry-type:datum-weak
+	  hash-table-entry-type:key&datum-ephemeral
+	  hash-table-entry-type:key-ephemeral
+	  hash-table-entry-type:key-weak
+	  hash-table-entry-type:key/datum-weak
+	  hash-table-entry-type:strong
 	  hash-table-exists?
 	  hash-table-fold
 	  hash-table-merge!
@@ -1993,6 +2004,7 @@ USA.
 	  hash-table-update!
 	  hash-table/clean!
 	  hash-table/clear!
+	  hash-table/constructor
 	  hash-table/count
 	  hash-table/datum-list
 	  hash-table/for-each
@@ -2012,19 +2024,17 @@ USA.
 	  hash-table?
 	  make-equal-hash-table
 	  make-hash-table
+	  make-hash-table*
+	  make-hash-table-type
 	  make-string-hash-table
 	  make-strong-eq-hash-table
 	  make-strong-eqv-hash-table
-	  make-weak-eq-hash-table
-	  make-weak-eqv-hash-table
 	  set-hash-table/rehash-size!
 	  set-hash-table/rehash-threshold!
 	  string-hash-table-type
 	  strong-eq-hash-table-type
 	  strong-eqv-hash-table-type
 	  strong-hash-table/constructor
-	  weak-eq-hash-table-type
-	  weak-eqv-hash-table-type
 	  weak-hash-table/constructor)
   (initialization (initialize-package!)))
 
diff --git a/tests/runtime/test-hash-table.scm b/tests/runtime/test-hash-table.scm
index 3895a078a..e2edfb2cc 100644
--- a/tests/runtime/test-hash-table.scm
+++ b/tests/runtime/test-hash-table.scm
@@ -127,47 +127,11 @@ USA.
 		       rb-tree/delete!
 		       rb-tree/lookup
 		       rb-tree->alist))
-
-(load-option 'HASH-TABLE)
-
-(define shtq
-  (make-implementation make-strong-eq-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 shtv
-  (make-implementation make-strong-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 whtq
-  (make-implementation make-weak-eq-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 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)))))))
+(load-option 'HASH-TABLE)
 
-(define ht
-  (make-implementation make-equal-hash-table
+(define (make-hash-table-implementation constructor)
+  (make-implementation constructor
 		       hash-table/put!
 		       hash-table/remove!
 		       hash-table/get
@@ -209,6 +173,8 @@ USA.
 		(error "Alist element incorrect:" (car alist) (car check)))
 	    (loop (cdr alist) (cdr check)))))))
 
+;;;; Correctness Tests
+
 (define (check implementation)
   (let ((n #x1000))
     (do ((i 0 (+ i 1))) ((= i #x100))
@@ -219,16 +185,43 @@ USA.
 	 (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)))
+(define (integer-hash-mod integer modulus)
+  (int:remainder (if (int:< integer 0) (int:- 0 integer) integer) modulus))
+
+(let ((hash-parameters
+       (list (list 'EQ eq-hash-mod eq? #t)
+	     (list 'EQV eqv-hash-mod eqv? #t)
+	     (list 'EQUAL equal-hash-mod equal? #t)
+	     (list 'INTEGER
+		   (lambda (x modulus) (integer-hash-mod (car x) modulus))
+		   (lambda (x y) (int:= (car x) (car y)))
+		   #f)))
+      (entry-types
+       (list (list 'STRONG hash-table-entry-type:strong)
+	     (list 'KEY-WEAK hash-table-entry-type:key-weak)
+	     (list 'DATUM-WEAK hash-table-entry-type:datum-weak)
+	     (list 'KEY/DATUM-WEAK hash-table-entry-type:key/datum-weak)
+	     (list 'KEY-EPHEMERAL hash-table-entry-type:key-ephemeral)
+	     (list 'DATUM-EPHEMERAL hash-table-entry-type:datum-ephemeral)
+	     (list 'KEY&DATUM-EPHEMERAL
+		   hash-table-entry-type:key&datum-ephemeral))))
+  (for-each (lambda (hash-parameters)
+	      (for-each (lambda (entry-type)
+			  (define-test
+			    (symbol-append 'CORRECTNESS-VS-RB:
+					   (car entry-type)
+					   '-
+					   (car hash-parameters))
+			    (lambda ()
+			      (check
+			       (make-hash-table-implementation
+				(apply hash-table/constructor
+				       (append (cdr hash-parameters)
+					       (cdr entry-type))))))))
+			entry-types))
+	    hash-parameters))
+
+;;;; Regression Tests
 
 ;;; These are carefully tailored to the internal representation of
 ;;; the hash table.  This is simpler, but less robust, than writing a