From e7371ce026173e48e885fe23817247802f6a38da Mon Sep 17 00:00:00 2001
From: Chris Hanson <org/chris-hanson/cph>
Date: Mon, 12 Mar 2018 22:18:37 -0700
Subject: [PATCH] Change representation of dispatch tags to eliminated nested
 "extra" vector.

---
 src/microcode/fixobj.h               |  2 +-
 src/runtime/bundle.scm               |  4 +-
 src/runtime/compound-predicate.scm   |  4 +-
 src/runtime/dispatch-tag.scm         | 61 +++++++++++++++++-----------
 src/runtime/parametric-predicate.scm |  4 +-
 src/runtime/record.scm               |  4 +-
 src/runtime/runtime.pkg              |  2 +
 src/sos/class.scm                    |  2 +-
 8 files changed, 49 insertions(+), 34 deletions(-)

diff --git a/src/microcode/fixobj.h b/src/microcode/fixobj.h
index 00b988d4b..49343a40a 100644
--- a/src/microcode/fixobj.h
+++ b/src/microcode/fixobj.h
@@ -63,7 +63,7 @@ USA.
 /* #define UNUSED		0x1E */
 /* #define UNUSED		0x1F */
 #define CC_ERROR_PROCEDURE	0x20	/* Error handler for compiled code. */
-/* #define UNUSED	 	0x21 */
+/* #define UNUSED		0x21 */
 /* #define UNUSED		0x22 */
 #define Primitive_Profiling_Table 0x23	/* Table of profile counts for
 					   primitives. */
diff --git a/src/runtime/bundle.scm b/src/runtime/bundle.scm
index 931a1eab5..9b2a118ce 100644
--- a/src/runtime/bundle.scm
+++ b/src/runtime/bundle.scm
@@ -100,10 +100,10 @@ USA.
        (bundle-interface-tag? (predicate->dispatch-tag object))))
 
 (define-integrable (tag-element-names tag)
-  (dispatch-tag-extra tag 0))
+  (dispatch-tag-extra-ref tag 0))
 
 (define-integrable (tag-element-properties tag)
-  (dispatch-tag-extra tag 1))
+  (dispatch-tag-extra-ref tag 1))
 
 (define (bundle-interface-name interface)
   (guarantee bundle-interface? interface 'bundle-interface-name)
diff --git a/src/runtime/compound-predicate.scm b/src/runtime/compound-predicate.scm
index 9cc5b72d5..c6f2cda05 100644
--- a/src/runtime/compound-predicate.scm
+++ b/src/runtime/compound-predicate.scm
@@ -42,10 +42,10 @@ USA.
 		      operands))
 
 (define-integrable (compound-tag-operator tag)
-  (dispatch-tag-extra tag 0))
+  (dispatch-tag-extra-ref tag 0))
 
 (define-integrable (compound-tag-operands tag)
-  (dispatch-tag-extra tag 1))
+  (dispatch-tag-extra-ref tag 1))
 
 (define (tag-is-disjoin? object)
   (and (compound-tag? object)
diff --git a/src/runtime/dispatch-tag.scm b/src/runtime/dispatch-tag.scm
index fbfc11c52..88e91cbb6 100644
--- a/src/runtime/dispatch-tag.scm
+++ b/src/runtime/dispatch-tag.scm
@@ -35,19 +35,20 @@ USA.
 
 (define (%make-tag metatag name predicate extra)
   (let ((tag
-	 (%record metatag
-		  (get-tag-cache-number)
-		  (get-tag-cache-number)
-		  (get-tag-cache-number)
-		  (get-tag-cache-number)
-		  (get-tag-cache-number)
-		  (get-tag-cache-number)
-		  (get-tag-cache-number)
-		  (get-tag-cache-number)
-		  name
-		  predicate
-		  extra
-		  (%make-weak-set))))
+	 (apply %record
+		metatag
+		(get-tag-cache-number)
+		(get-tag-cache-number)
+		(get-tag-cache-number)
+		(get-tag-cache-number)
+		(get-tag-cache-number)
+		(get-tag-cache-number)
+		(get-tag-cache-number)
+		(get-tag-cache-number)
+		name
+		predicate
+		(%make-weak-set)
+		extra)))
     (set-predicate-tag! predicate tag)
     tag))
 
@@ -73,11 +74,14 @@ USA.
 (define-integrable (%dispatch-tag->predicate tag)
   (%record-ref tag 10))
 
-(define-integrable (%dispatch-tag-extra tag)
+(define-integrable (%tag-supersets tag)
   (%record-ref tag 11))
 
-(define-integrable (%tag-supersets tag)
-  (%record-ref tag 12))
+(define-integrable (%dispatch-tag-extra-ref tag index)
+  (%record-ref tag (fix:+ 12 index)))
+
+(define-integrable (%dispatch-tag-extra-length tag)
+  (fix:- (%record-length tag) 12))
 
 (define-integrable tag-cache-number-adds-ok
   ;; This constant controls the number of non-zero bits tag cache
@@ -105,7 +109,7 @@ USA.
 	(lambda (object)
 	  (and (%record? object)
 	       (eq? metatag (%record-ref object 0)))))
-       (metatag (%make-tag metatag-tag name predicate '#())))
+       (metatag (%make-tag metatag-tag name predicate '())))
     (set-dispatch-tag<=! metatag metatag-tag)
     metatag))
 
@@ -116,7 +120,7 @@ USA.
     (guarantee unary-procedure? predicate caller)
     (if (predicate? predicate)
 	(error "Can't assign multiple tags to the same predicate:" name))
-    (%make-tag metatag name predicate (list->vector extra))))
+    (%make-tag metatag name predicate extra)))
 
 (define (dispatch-metatag? object)
   (and (%record? object)
@@ -126,9 +130,9 @@ USA.
 (define metatag-tag)
 (add-boot-init!
  (lambda ()
-   (set! metatag-tag (%make-tag #f 'metatag dispatch-metatag? '#()))
+   (set! metatag-tag (%make-tag #f 'metatag dispatch-metatag? '()))
    (%record-set! metatag-tag 0 metatag-tag)))
-
+
 (define (dispatch-tag-metatag tag)
   (guarantee dispatch-tag? tag 'dispatch-tag-metatag)
   (%record-ref tag 0))
@@ -141,9 +145,18 @@ USA.
   (guarantee dispatch-tag? tag 'dispatch-tag->predicate)
   (%dispatch-tag->predicate tag))
 
-(define (dispatch-tag-extra tag index)
-  (guarantee dispatch-tag? tag 'dispatch-tag-extra)
-  (vector-ref (%dispatch-tag-extra tag) index))
+(define (dispatch-tag-extra-ref tag index)
+  (guarantee dispatch-tag? tag 'dispatch-tag-extra-ref)
+  (%dispatch-tag-extra-ref tag index))
+
+(define (dispatch-tag-extra-length tag)
+  (guarantee dispatch-tag? tag 'dispatch-tag-extra-length)
+  (%dispatch-tag-extra-length tag))
+
+(define (dispatch-tag-extra tag)
+  (do ((i (fix:- (dispatch-tag-extra-length tag) 1) (fix:- i 1))
+       (elts '() (cons (%dispatch-tag-extra-ref tag i) elts)))
+      ((fix:< i 0) elts)))
 
 (define (any-dispatch-tag-superset procedure tag)
   (guarantee dispatch-tag? tag 'any-dispatch-tag-superset)
@@ -169,4 +182,4 @@ USA.
     (list (list 'metatag (dispatch-tag-metatag tag))
 	  (list 'name (dispatch-tag-name tag))
 	  (list 'predicate (dispatch-tag->predicate tag))
-	  (cons 'extra (vector->list (%dispatch-tag-extra tag))))))
\ No newline at end of file
+	  (cons 'extra (dispatch-tag-extra tag)))))
\ No newline at end of file
diff --git a/src/runtime/parametric-predicate.scm b/src/runtime/parametric-predicate.scm
index 9e6fc918b..05b5a866f 100644
--- a/src/runtime/parametric-predicate.scm
+++ b/src/runtime/parametric-predicate.scm
@@ -39,10 +39,10 @@ USA.
   (%make-parametric-tag name predicate template bindings))
 
 (define-integrable (parametric-tag-template tag)
-  (dispatch-tag-extra tag 0))
+  (dispatch-tag-extra-ref tag 0))
 
 (define-integrable (parametric-tag-bindings tag)
-  (dispatch-tag-extra tag 1))
+  (dispatch-tag-extra-ref tag 1))
 
 (define (parametric-predicate? object)
   (and (predicate? object)
diff --git a/src/runtime/record.scm b/src/runtime/record.scm
index e49267301..f0c28ac86 100644
--- a/src/runtime/record.scm
+++ b/src/runtime/record.scm
@@ -108,10 +108,10 @@ USA.
   record-type)
 
 (define-integrable (%record-type-field-names record-type)
-  (dispatch-tag-extra record-type 0))
+  (dispatch-tag-extra-ref record-type 0))
 
 (define-integrable (%record-type-default-inits record-type)
-  (dispatch-tag-extra record-type 1))
+  (dispatch-tag-extra-ref record-type 1))
 
 (define-integrable (%record-type-n-fields record-type)
   (vector-length (%record-type-field-names record-type)))
diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index f66f347ac..fdeed14ba 100644
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -5084,6 +5084,8 @@ USA.
 	  dispatch-metatag?
 	  dispatch-tag->predicate
 	  dispatch-tag-extra
+	  dispatch-tag-extra-length
+	  dispatch-tag-extra-ref
 	  dispatch-tag-metatag
 	  dispatch-tag-name
 	  dispatch-tag?
diff --git a/src/sos/class.scm b/src/sos/class.scm
index d04dc2a2c..ed740dc7c 100644
--- a/src/sos/class.scm
+++ b/src/sos/class.scm
@@ -347,7 +347,7 @@ USA.
   (record-type-class (record-type-descriptor record)))
 
 (define (dispatch-tag->class tag)
-  (cond ((class-tag? tag) (dispatch-tag-extra tag 0))
+  (cond ((class-tag? tag) (dispatch-tag-extra-ref tag 0))
 	((hash-table/get built-in-class-table tag #f))
 	((record-type? tag)
 	 (let ((class (make-record-type-class tag)))
-- 
2.25.1