Change representation of dispatch tags to eliminated nested "extra" vector.

diff --git a/src/microcode/fixobj.h b/src/microcode/fixobj.h
index 00b988d4b78933551338ae2f1aa81fd72664f042..49343a40a1a5a067b08a55529a1ee9b2dc1e86de 100644 (file)
--- 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 931a1eab59acca2fb15fcc87f6d698b1716b4b8c..9b2a118ce1737d905f448d1de8bd7aaa200fcb29 100644 (file)
--- 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 9cc5b72d554d5e8491e01f93c67be0884298f79d..c6f2cda05057dae9312f793e82a641f6669a4519 100644 (file)
--- 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 fbfc11c52a4d090c536ef8fdfc543322e43bb155..88e91cbb6a238c8e94cb4dfdd276e5635eea9cd0 100644 (file)
--- a/src/runtime/dispatch-tag.scm
+++ b/src/runtime/dispatch-tag.scm
@@ -35,19 +35,20 @@ USA.
 \f
 (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)))
-
+\f
 (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 9e6fc918b4fc30b71e9be4b795ee8e8473c483f7..05b5a866f376a69af55070a1f5f3d65136a179a3 100644 (file)
--- 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 e49267301503766564581b6cd9da69d291dfee85..f0c28ac86e7ec61568bf8a7254fa118acc3a9e1d 100644 (file)
--- 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 f66f347accfed1e8da21fbda586312c6f6201ce9..fdeed14ba669aa44e86c43b24b351f6535d3fafc 100644 (file)
--- 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 d04dc2a2c69ed1c2300687e8d3c86481bfeb2498..ed740dc7c31814ce160d69a09f9f0336434ee75a 100644 (file)
--- 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)))