From: Stephen Adams <edu/mit/csail/zurich/adams>
Date: Thu, 10 Aug 1995 13:50:13 +0000 (+0000)
Subject: Add MONOTONIC-STRONG-EQ-HASH-TABLEs.
X-Git-Tag: 20090517-FFI~6044
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=fa298f7f5f46bd012ed1fb9c675d82b25f1985eb;p=mit-scheme.git

Add MONOTONIC-STRONG-EQ-HASH-TABLEs.
---

diff --git a/v8/src/compiler/midend/utils.scm b/v8/src/compiler/midend/utils.scm
index 21f7485b7..e4bc7abe9 100644
--- a/v8/src/compiler/midend/utils.scm
+++ b/v8/src/compiler/midend/utils.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: utils.scm,v 1.27 1995/07/13 04:00:09 adams Exp $
+$Id: utils.scm,v 1.28 1995/08/10 13:50:13 adams Exp $
 
 Copyright (c) 1994-1995 Massachusetts Institute of Technology
 
@@ -1134,41 +1134,41 @@ Example use of FORM/COPY-TRANSFORMING:
        (acc '() (cons i acc)))
       ((< i 0) acc)))
 
-(define code/rewrite-table/make
-  (strong-hash-table/constructor eq-hash-mod eq? true))
+;;(define code/rewrite-table/make
+;;  (strong-hash-table/constructor eq-hash-mod eq? true))
 
 (define code-rewrite/remember
   (let ((not-found (list '*NOT-FOUND*)))
     (lambda (new old)
       (let ((crt *code-rewrite-table*))
-	(if (and crt (eq? not-found (hash-table/get crt new not-found)))
+	(if (and crt (eq? not-found (code-rewrite-table/get crt new not-found)))
 	    (let* ((pcrt *previous-code-rewrite-table*)
 		   (old* (if (not pcrt)
 			     not-found
-			     (hash-table/get pcrt
-					     old
-					     not-found))))
+			     (code-rewrite-table/get pcrt
+						     old
+						     not-found))))
 	      (cond ((not (eq? old* not-found))
-		     (hash-table/put! crt new old*))
+		     (code-rewrite-table/put! crt new old*))
 		    ((eq? pcrt #t)
-		     (hash-table/put! crt new old))))))
+		     (code-rewrite-table/put! crt new old))))))
       new)))
 
 (define code-rewrite/remember*
   (let ((not-found (list '*NOT-FOUND*)))
     (lambda (new old)
       (let ((crt *code-rewrite-table*))
-	(if (and crt (eq? not-found (hash-table/get crt new not-found)))
-	    (hash-table/put! crt new old)))
+	(if (and crt (eq? not-found (code-rewrite-table/get crt new not-found)))
+	    (code-rewrite-table/put! crt new old)))
       new)))
 
 (define code-rewrite/remember*!
   (lambda (new old)
-    (hash-table/put! *code-rewrite-table* new old)))
+    (code-rewrite-table/put! *code-rewrite-table* new old)))
 
 (define (code-rewrite/original-form new)
   (and *code-rewrite-table*
-       (hash-table/get *code-rewrite-table* new false)))
+       (code-rewrite-table/get *code-rewrite-table* new false)))
 
 (define code-rewrite/original-form*/previous
   (let ((not-found (list '*NOT-FOUND*)))
@@ -1177,18 +1177,21 @@ Example use of FORM/COPY-TRANSFORMING:
       (if (not *previous-code-rewrite-table*)
 	  (values false old)
 	  (let ((ancient
-		 (hash-table/get *previous-code-rewrite-table* old not-found)))
+		 (code-rewrite-table/get *previous-code-rewrite-table*
+					 old not-found)))
 	    (if (eq? not-found ancient)
 		(values false old)
 		(values true ancient)))))))      
 
 (define (code-rewrite/original-form/previous old)
   (and *previous-code-rewrite-table*
-       (hash-table/get *previous-code-rewrite-table* old false)))
+       (code-rewrite-table/get *previous-code-rewrite-table* old false)))
 
+;;(define (code/rewrite-table/copy table)
+;;  (hash-table/copy table
+;;		   code/rewrite-table/make))
 (define (code/rewrite-table/copy table)
-  (hash-table/copy table
-		   code/rewrite-table/make))
+  (monotonic-strong-eq-hash-table/copy table))
 
 (define (kmp-program-size program)
   (let walk ((program program) (size 0))
@@ -1242,4 +1245,169 @@ Example use of FORM/COPY-TRANSFORMING:
 			     (lambda (a b)
 			       (lambda (name)
 				 (and (a name) (b name))))))
-	  (else #F))))
\ No newline at end of file
+	  (else #F))))
+
+
+;; This implementation is not thread-safe.  Do not share these
+;; hash-tables between cncurrent threads.
+;;
+;; (make-monotonic-strong-eq-hash-table)
+;; (monotonic-strong-eq-hash-table/put! table key value)
+;; (monotonic-strong-eq-hash-table/for-every table procedure)
+;; (monotonic-strong-eq-hash-table/get table key default)
+;; (monotonic-strong-eq-hash-table/copy table)
+
+(declare (usual-integrations))
+
+(define-structure (table
+		   (conc-name table/))
+  ;; either #F, #T (rehash because of GC), or the old vector (rehash
+  ;; because of growth (or growth and GC)).
+  rehash?
+  vector
+  count)
+
+(define tables)
+
+(define-integrable empty-slot #F)
+
+(define-integrable (eq-hash-mask key mask)
+  (let ((key key))
+    (fix:and
+     (fix:* #b1001101011
+	    (fix:+ (object-datum key) (fix:lsh (object-datum key) -9)))
+     mask)))
+
+(define (table/grow! table)
+  (let* ((old      (table/vector table))
+	 (old-len  (vector-length old))
+	 (new-len  (fix:* 2 old-len))
+	 (new      (make-vector new-len empty-slot)))
+    (set-table/rehash?! table old)
+    (set-table/vector! table new)))
+
+(define (make-monotonic-strong-eq-hash-table)
+  (let ((hash-table
+	 (make-table #F
+		     (let ((e empty-slot))
+		       (vector e e e e e e e e))
+		     0)))
+    (set-cdr! tables (weak-cons hash-table (cdr tables)))
+    hash-table))
+
+(define (monotonic-strong-eq-hash-table/copy table)
+  (let ((rehash?  (table/rehash? table))
+	(count    (table/count table))
+	(vector   (table/vector table)))
+    (let ((vector*  (vector-copy vector))
+	  (rehash?* (if (vector? rehash?) (vector-copy rehash?) rehash?)))
+      (let ((table* (make-table rehash?* vector* count)))
+	(set-cdr! tables (weak-cons table* (cdr tables)))
+	;; Now we may have GC-ed and require a rehash
+	(if (and (table/rehash? table)
+		 (not (table/rehash? table*)))
+	    (set-table/rehash?! table* #T))
+	table*))))
+
+(define (monotonic-strong-eq-hash-table/put! table key datum)
+
+  (if (table/rehash? table)
+      (table/rehash! table))
+
+  (let* ((v      (table/vector table))
+	 (len    (vector-length v))
+	 (mask   (fix:- len 2))		;#b00...0011...110
+	 (start  (eq-hash-mask key mask)))
+    (let search ((i  start))
+      (cond  ((eq? (vector-ref v i) key)
+	      (vector-set! v (fix:+ i 1) datum)
+	      #F)
+	     ((eq? (vector-ref v i) empty-slot)
+	      ;; Assumption: There will be no interrupt checks between the
+	      ;; above vector-ref and the following vector-set!s
+	      (vector-set! v i key)
+	      (vector-set! v (fix:+ i 1) datum)
+	      (set-table/count! table (fix:+ (table/count table) 1))
+	      ;; We must ensure that the table is NEVER full
+	      (if (fix:> (fix:* 3 (table/count table)) len)
+		  (table/grow! table))
+	      #T)
+	     (else
+	      (search (fix:and mask (fix:+ i 2))))))))
+
+(define (monotonic-strong-eq-hash-table/get table key default)
+
+  (define-integrable (retry)
+    (table/rehash! table)
+    (monotonic-strong-eq-hash-table/get table key default))
+    
+  (let* ((v      (table/vector table))
+	 (len    (vector-length v))
+	 (mask   (fix:- len 2))		; #b00...0011...110
+	 (start  (eq-hash-mask key mask)))
+    (let search ((i  start))
+      (cond  ((eq? (vector-ref v i) key)
+	      (vector-ref v (fix:+ i 1)))
+	     ((eq? (vector-ref v i) empty-slot)
+	      (if (table/rehash? table)
+		  (retry)
+		  default))
+	     (else
+	      (search (fix:and mask (fix:+ i 2))))))))
+
+(define (table/rehash! table)
+
+  (define (rehash-copy old old-len new new-len)
+    (let ((mask (fix:- new-len 2)))
+      (let loop ((old-i (fix:- old-len 2)))
+	(if (fix:>= old-i 0)
+	    (let ((key  (vector-ref old old-i)))
+	      (let search ((new-i  (eq-hash-mask key mask)))
+		(cond ((eq? (vector-ref new new-i) empty-slot)
+		       (vector-set! new new-i key)
+		       (vector-set! new (fix:+ new-i 1)
+				    (vector-ref old (fix:+ old-i 1)))
+		       (loop (fix:- old-i 2)))
+		      (else
+		       (search (fix:and mask (fix:+ new-i 2)))))))))))
+
+  (if (vector? (table/rehash? table))
+      (let ((old (table/rehash? table))
+	    (new (table/vector table)))
+	(set-table/rehash?! table false)
+	(rehash-copy old (vector-length old) new (vector-length new)))
+      (let* ((vec  (table/vector table))
+	     (len  (vector-length vec))
+	     (new  (make-vector len empty-slot)))
+	(set-table/rehash?! table #F)
+	(set-table/vector! table new)
+	(rehash-copy vec len new len))))
+
+(define (mark-tables!)
+  (let loop ((tables tables))
+    (let ((wp (system-pair-cdr tables)))
+      (cond ((null? wp)
+	     unspecific)
+	    ((system-pair-car wp)
+	     => (lambda (table)
+		  (if (not (table/rehash? table))
+		      (set-table/rehash?! table #T))
+		  (loop wp)))
+	    (else
+	     ;; discard weak pair
+	     (system-pair-set-cdr! tables (system-pair-cdr wp))
+	     (loop tables))))))
+
+(define (initialize-package!)
+  (set! tables (cons 'HEAD '()))
+  ;;((access add-primitive-gc-daemon! (->environment '(runtime gc-daemons)))
+  ;; mark-tables!)
+  (add-gc-daemon! mark-tables!)
+)
+
+(initialize-package!)
+
+(define code/rewrite-table/make make-monotonic-strong-eq-hash-table)
+
+(define code-rewrite-table/get  monotonic-strong-eq-hash-table/get)
+(define code-rewrite-table/put! monotonic-strong-eq-hash-table/put!)