From 475ab2ffd212f90a9091d12ea4d6d0ffa313cbea Mon Sep 17 00:00:00 2001
From: Chris Hanson <org/chris-hanson/cph>
Date: Sat, 13 Jan 2018 20:16:52 -0800
Subject: [PATCH] Refactor handling of explicit tag supersets.

Was hash table, now is weak list.
---
 src/runtime/predicate-lattice.scm  |  8 ++--
 src/runtime/predicate-metadata.scm | 67 +++++++++++++++++++++++-------
 src/runtime/runtime.pkg            |  4 +-
 3 files changed, 57 insertions(+), 22 deletions(-)

diff --git a/src/runtime/predicate-lattice.scm b/src/runtime/predicate-lattice.scm
index c74c9f978..d85f92139 100644
--- a/src/runtime/predicate-lattice.scm
+++ b/src/runtime/predicate-lattice.scm
@@ -67,9 +67,9 @@ USA.
 			tag<=-overrides)))
 	     (if v
 		 ((vector-ref v 2) tag1 tag2)
-		 (any (lambda (tag)
-			(cached-tag<= tag tag2))
-		      (get-tag-supersets tag1)))))))
+		 (any-tag-superset (lambda (tag)
+				     (cached-tag<= tag tag2))
+				   tag1))))))
 
 (define (define-tag<= test1 test2 handler)
   (set! tag<=-overrides
@@ -111,8 +111,6 @@ USA.
   (if (and (eq? operator 'set-tag<=!)
            (pair? rest))
       (let ((superset (car rest)))
-        (if (tag<= tag superset)
-            (error "Tag already has this superset:" tag superset))
         (if (tag>= tag superset)
             (error "Not allowed to create a superset loop:" tag superset))))
   (hash-table-clear! tag<=-cache))
\ No newline at end of file
diff --git a/src/runtime/predicate-metadata.scm b/src/runtime/predicate-metadata.scm
index 804e0570b..d572b7586 100644
--- a/src/runtime/predicate-metadata.scm
+++ b/src/runtime/predicate-metadata.scm
@@ -104,8 +104,7 @@ USA.
 		    (if (default-object? description)
 			(delay (object->description name))
 			(delay description))
-		    (make-key-weak-eq-hash-table)
-		    (make-key-weak-eq-hash-table))))
+		    (%make-weak-set))))
     (set-predicate-tag! predicate tag)
     tag))
 
@@ -125,14 +124,13 @@ USA.
       (write object port))))
 
 (define-record-type <tag>
-    (%make-tag name predicate extra description subsets supersets)
+    (%make-tag name predicate extra description supersets)
     tag?
   (name tag-name)
   (predicate tag->predicate)
   (extra tag-extra)
   (description %tag-description)
-  (subsets tag-subsets)
-  (supersets tag-supersets))
+  (supersets %tag-supersets))
 
 (define-unparser-method tag?
   (simple-unparser-method 'tag
@@ -142,19 +140,58 @@ USA.
 (define (tag-description tag)
   (force (%tag-description tag)))
 
-(define (get-tag-subsets tag)
-  (hash-table-keys (tag-subsets tag)))
+(define (tag-supersets tag)
+  (%weak-set->list (%tag-supersets tag)))
 
-(define (get-tag-supersets tag)
-  (hash-table-keys (tag-supersets tag)))
+(define (any-tag-superset predicate tag)
+  (%weak-set-any predicate (%tag-supersets tag)))
 
 (define (set-tag<=! tag superset)
-  (event-distributor/invoke! event:predicate-metadata 'set-tag<=! tag superset)
-  (%link! tag superset))
-
-(define (%link! subset superset)
-  (hash-table-set! (tag-subsets superset) subset subset)
-  (hash-table-set! (tag-supersets subset) superset superset))
+  (guarantee tag? superset 'set-tag<=!)
+  (if (%add-to-weak-set superset (%tag-supersets tag))
+      (event-distributor/invoke! event:predicate-metadata
+				 'set-tag<=! tag superset)
+      (error "Tag already has this superset:" tag superset)))
+
+(define (%make-weak-set)
+  (%weak-cons 'weak-set '()))
+
+(define (%weak-set->list weak-set)
+  (weak-list->list (weak-cdr weak-set)))
+
+(define (%add-to-weak-set item weak-set)
+  (let loop
+      ((this (weak-cdr weak-set))
+       (prev weak-set))
+    (if (weak-pair? this)
+	(let ((item* (%weak-car this))
+	      (next (weak-cdr this)))
+	  (cond ((not item*)
+		 (weak-set-cdr! prev next)
+		 (loop next prev))
+		((eq? item item*)
+		 #f)
+		(else
+		 (loop next this))))
+	(begin
+	  (weak-set-cdr! prev (%weak-cons item '()))
+	  #t))))
+
+(define (%weak-set-any predicate weak-set)
+  (let loop
+      ((this (weak-cdr weak-set))
+       (prev weak-set))
+    (if (weak-pair? this)
+	(let ((item (%weak-car this))
+	      (next (weak-cdr this)))
+	  (cond ((not item)
+		 (weak-set-cdr! prev next)
+		 (loop next prev))
+		((predicate item)
+		 #t)
+		(else
+		 (loop next this))))
+	#f)))
 
 (define event:predicate-metadata (make-event-distributor))
 
diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index 181d77039..80f2290a6 100644
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -1840,9 +1840,8 @@ USA.
 	  predicate-name
 	  set-predicate<=!)
   (export (runtime)
+	  any-tag-superset
 	  event:predicate-metadata
-	  get-tag-subsets
-	  get-tag-supersets
 	  make-tag
 	  predicate->tag
 	  set-tag<=!
@@ -1850,6 +1849,7 @@ USA.
 	  tag-description
 	  tag-extra
 	  tag-name
+	  tag-supersets
 	  tag?))
 
 (define-package (runtime predicate-lattice)
-- 
2.25.1