From 93589796696864370c8f61b2f0df411aa494426a Mon Sep 17 00:00:00 2001
From: Matt Birkholz <puck@birchwood-abbey.net>
Date: Thu, 18 Jun 2015 12:56:42 -0700
Subject: [PATCH] Remove with-absolutely-no-interrupts from runtime/hash.scm.

Use a thread mutex to serialize access.  Simplify an ancient
implementation by using the new datum weak and key weak hash table
types. Initialize the package AFTER (runtime hash-table).
---
 src/runtime/hash.scm | 244 ++++++++-----------------------------------
 src/runtime/make.scm |   2 +-
 2 files changed, 43 insertions(+), 203 deletions(-)

diff --git a/src/runtime/hash.scm b/src/runtime/hash.scm
index 23ad9df03..c5132afb4 100644
--- a/src/runtime/hash.scm
+++ b/src/runtime/hash.scm
@@ -31,97 +31,48 @@ USA.
 
 ;;;; Object hashing
 
-;;; The hashing code depends on weak conses supported by the
-;;; microcode.  In particular, it depends on the fact that the car of
-;;; a weak cons becomes #F if the object is garbage collected.
-
-;;; Important: This code must be rewritten for a parallel processor,
-;;; since two processors may be updating the data structures
-;;; simultaneously.
-
 ;;; How this works:
 
 ;;; There are two tables, the hash table and the unhash table:
 
 ;;; - The hash table associates objects to their hash numbers.  The
-;;; entries are keyed according to the address (datum) of the object,
-;;; and thus must be recomputed after every relocation (ie. band
-;;; loading, garbage collection, etc.).
+;;; entries are keyed according to the address (datum) of the object.
 
 ;;; - The unhash table associates the hash numbers with the
 ;;; corresponding objects.  It is keyed according to the numbers
 ;;; themselves.
 
-;;; In order to make the hash and unhash tables weakly hold the
-;;; objects hashed, the following mechanism is used:
-
-;;; The hash table, a vector, has a NMV header before all the
-;;; buckets, and therefore the garbage collector will skip it and will
-;;; not relocate its buckets.  It becomes invalid after a garbage
-;;; collection and the first thing the daemon does is clear it.  Each
-;;; bucket is a normal alist with the objects in the cars, and the
-;;; numbers in the cdrs, thus assq can be used to find an object in
-;;; the bucket.
-
-;;; The unhash table, also a vector, holds the objects by means of
-;;; weak conses.  These weak conses are the same as the pairs in the
-;;; buckets in the hash table, but with their type codes changed.
-;;; Each of the buckets in the unhash table is headed by an extra pair
-;;; whose car is usually #T.  This pair is used by the splicing code.
-;;; The daemon treats buckets headed by #F differently from buckets
-;;; headed by #T.  A bucket headed by #T is compressed: Those pairs
-;;; whose cars have disappeared are spliced out from the bucket.  On
-;;; the other hand, buckets headed by #F are not compressed.  The
-;;; intent is that while object-unhash is traversing a bucket, the
-;;; bucket is locked so that the daemon will not splice it out behind
-;;; object-unhash's back.  Then object-unhash does not need to be
-;;; locked against garbage collection.
+;;; Both tables hold the objects weakly.  Thus the hash table holds
+;;; its keys weakly, and the unhash table holds its values weakly.
 
 (define default/hash-table-size 313)
 (define default-hash-table)
-(define all-hash-tables)
 
 (define (initialize-package!)
-  (set! all-hash-tables (weak-cons 0 '()))
-  (set! default-hash-table (hash-table/make))
-  (add-event-receiver! event:after-restore (lambda () (gc-flip)))
-  (add-primitive-gc-daemon! rehash-all-gc-daemon))
+  (set! make-datum-weak-eq-hash-table
+	(hash-table/constructor eq-hash-mod eq? #f
+				hash-table-entry-type:datum-weak))
+  (set! default-hash-table (hash-table/make)))
 
 (define-structure (hash-table
 		   (conc-name hash-table/)
 		   (constructor %hash-table/make))
-  (size)
+  (mutex)
   (next-number)
   (hash-table)
   (unhash-table))
 
+(define make-datum-weak-eq-hash-table)
+
 (define (hash-table/make #!optional size)
-  (let* ((size (if (default-object? size)
-		   default/hash-table-size
-		   size))
-	 (table
-	  (%hash-table/make
-	   size
-	   1
-	   (let ((table (make-vector (+ size 1) '())))
-	     (vector-set! table
-			  0
-			  ((ucode-primitive primitive-object-set-type)
-			   (ucode-type manifest-nm-vector)
-			   (make-non-pointer-object size)))
-	     ((ucode-primitive primitive-object-set-type)
-	      (ucode-type non-marked-vector)
-	      table))
-	   (let ((table (make-vector size '())))
-	     (let loop ((n 0))
-	       (if (fix:< n size)
-		   (begin
-		     (vector-set! table n (cons #t '()))
-		     (loop (fix:+ n 1)))))
-	     table))))
-    (weak-set-cdr! all-hash-tables
-		   (weak-cons table (weak-cdr all-hash-tables)))
-    table))
+  (let ((size (if (default-object? size)
+		  default/hash-table-size
+		  size)))
+    (%hash-table/make
+     (make-thread-mutex)
+     1
+     (make-key-weak-eq-hash-table size)
+     (make-datum-weak-eq-hash-table size))))
 
 (define (hash x #!optional table)
   (if (eq? x #f)
@@ -152,8 +103,6 @@ USA.
 		   (if (default-object? table) default-hash-table table)
 		   #f)))
 
-;;; This can cons a bit when interpreted.
-
 (define (object-hash object #!optional table insert?)
   (let ((table
 	 (if (default-object? table)
@@ -165,140 +114,31 @@ USA.
 					      'OBJECT-HASH))
 	       table)))
 	(insert? (or (default-object? insert?) insert?)))
-    (with-absolutely-no-interrupts
+    (with-thread-mutex-lock (hash-table/mutex table)
       (lambda ()
-	(let* ((hash-index (fix:+ 1
-				  (modulo (object-datum object)
-					  (hash-table/size table))))
-	       (the-hash-table
-		((ucode-primitive primitive-object-set-type)
-		 (ucode-type vector)
-		 (hash-table/hash-table table)))
-	       (bucket (vector-ref the-hash-table hash-index))
-	       (association (assq object bucket)))
-	  (cond (association (cdr association))
-		((not insert?) #f)
-		(else
-		 (let ((result (hash-table/next-number table)))
-		   (let ((pair (cons object result))
-			 (unhash-bucket
-			  (vector-ref (hash-table/unhash-table table)
-				      (modulo result
-					      (hash-table/size table)))))
-		     (set-hash-table/next-number! table (+ result 1))
-		     (vector-set! the-hash-table
-				  hash-index
-				  (cons pair bucket))
-		     (set-cdr! unhash-bucket
-			       (cons (object-new-type (ucode-type weak-cons)
-						      pair)
-				     (cdr unhash-bucket)))
-		     result)))))))))
-
-;;; This is safe because it locks the garbage collector out only for a
-;;; little time, enough to tag the bucket being searched, so that the
-;;; daemon will not splice that bucket.
+	(let ((number (hash-table/get (hash-table/hash-table table) object #f)))
+	  (if (not number)
+	      (if insert?
+		  (let ((hashtb (hash-table/hash-table table))
+			(unhashtb (hash-table/unhash-table table))
+			(next (hash-table/next-number table)))
+		    (set-hash-table/next-number! table (1+ next))
+		    (hash-table/put! unhashtb next object)
+		    (hash-table/put! hashtb object next)
+		    next)
+		  number)
+	      number))))))
 
 (define (object-unhash number #!optional table)
-  (let* ((table
-	  (if (default-object? table)
-	      default-hash-table
-	      (begin
-		(if (not (hash-table? table))
-		    (error:wrong-type-argument table
-					       "object-hash table"
-					       'OBJECT-UNHASH))
-		table)))
-	 (index (modulo number (hash-table/size table))))
-    (with-absolutely-no-interrupts
+  (let ((table
+	 (if (default-object? table)
+	     default-hash-table
+	     (begin
+	       (if (not (hash-table? table))
+		   (error:wrong-type-argument table
+					      "object-hash table"
+					      'OBJECT-UNHASH))
+	       table))))
+    (with-thread-mutex-lock (hash-table/mutex table)
       (lambda ()
-	(let ((bucket (vector-ref (hash-table/unhash-table table) index)))
-	  (set-car! bucket #f)
-	  (let ((result
-		 (with-interrupt-mask interrupt-mask/gc-ok
-		   (lambda (interrupt-mask)
-		     interrupt-mask
-		     (let loop ((l (cdr bucket)))
-		       (cond ((null? l) #f)
-			     ((= number (system-pair-cdr (car l)))
-			      (system-pair-car (car l)))
-			     (else (loop (cdr l)))))))))
-	    (set-car! bucket #t)
-	    result))))))
-
-;;;; Rehash daemon
-
-;;; The following is dangerous because of the (unnecessary) consing
-;;; done by the interpreter while it executes the loops.  It runs with
-;;; interrupts turned off.  The (necessary) consing done by rehash is
-;;; not dangerous because at least that much storage was freed by the
-;;; garbage collector.  To understand this, notice that the hash table
-;;; has a SNMV header, so the garbage collector does not trace the
-;;; hash table buckets, therefore freeing their storage.  The header
-;;; is SNM rather than NM to make the buckets be relocated at band
-;;; load/restore time.
-
-;;; Until this code is compiled, and therefore safe, it is replaced by
-;;; a primitive.  See the installation code below.
-#|
-(define (hash-table/rehash table)
-  (let ((hash-table-size (hash-table/size table))
-	(hash-table ((ucode-primitive primitive-object-set-type)
-		     (ucode-type vector)
-		     (hash-table/hash-table table)))
-	(unhash-table (hash-table/unhash-table table)))
-
-    (define (rehash weak-pair)
-      (let ((index
-	     (fix:+ 1 (modulo (object-datum (system-pair-car weak-pair))
-			      hash-table-size))))
-	(vector-set! hash-table
-		     index
-		     (cons (object-new-type (ucode-type pair) weak-pair)
-			   (vector-ref hash-table index)))
-	unspecific))
-
-    (let cleanup ((n hash-table-size))
-      (if (not (fix:= n 0))
-	  (begin
-	    (vector-set! hash-table n '())
-	    (cleanup (fix:- n 1)))))
-
-    (let outer ((n (fix:- hash-table-size 1)))
-      (if (not (fix:< n 0))
-	  (let ((bucket (vector-ref unhash-table n)))
-	    (if (car bucket)
-		(let inner1 ((l1 bucket) (l2 (cdr bucket)))
-		  (cond ((null? l2)
-			 (outer (fix:- n 1)))
-			((eq? (system-pair-car (car l2)) #f)
-			 (set-cdr! l1 (cdr l2))
-			 (inner1 l1 (cdr l1)))
-			(else
-			 (rehash (car l2))
-			 (inner1 l2 (cdr l2)))))
-		(let inner2 ((l (cdr bucket)))
-		  (cond ((null? l)
-			 (outer (fix:- n 1)))
-			((eq? (system-pair-car (car l)) #f)
-			 (inner2 (cdr l)))
-			(else
-			 (rehash (car l))
-			 (inner2 (cdr l)))))))))))
-|#
-
-(define-integrable (hash-table/rehash table)
-  ((ucode-primitive rehash) (hash-table/unhash-table table)
-			    (hash-table/hash-table table)))
-
-(define (rehash-all-gc-daemon)
-  (let loop ((l all-hash-tables)
-	     (n (weak-cdr all-hash-tables)))
-    (cond ((null? n)
-	   (weak-set-cdr! l n))
-	  ((not (weak-pair/car? n))
-	   (loop l (weak-cdr n)))
-	  (else
-	   (weak-set-cdr! l n)
-	   (hash-table/rehash (weak-car n))
-	   (loop n (weak-cdr n))))))
\ No newline at end of file
+	(hash-table/get (hash-table/unhash-table table) number #f)))))
\ No newline at end of file
diff --git a/src/runtime/make.scm b/src/runtime/make.scm
index e04a023d2..6ca4c4376 100644
--- a/src/runtime/make.scm
+++ b/src/runtime/make.scm
@@ -437,7 +437,6 @@ USA.
    ;; Microcode interface
    ((RUNTIME MICROCODE-TABLES) READ-MICROCODE-TABLES!)
    (RUNTIME APPLY)
-   (RUNTIME HASH)			; First GC daemon!
    (RUNTIME PRIMITIVE-IO)
    (RUNTIME SYSTEM-CLOCK)
    ((RUNTIME GC-FINALIZER) INITIALIZE-EVENTS!)
@@ -451,6 +450,7 @@ USA.
    (RUNTIME STREAM)
    (RUNTIME 2D-PROPERTY)
    (RUNTIME HASH-TABLE)
+   (RUNTIME HASH)
    (RUNTIME REGULAR-SEXPRESSION)
    ;; Microcode data structures
    (RUNTIME HISTORY)
-- 
2.25.1