Make noop-tag-property a slot in the vector tag.

diff --git a/src/compiler/base/cfg2.scm b/src/compiler/base/cfg2.scm
index ba9e8bcf08b23fecf5aa48f6a1033b182e336918..48e1b64ae49a35eb84d8fea5cfa3a3d4c037ccc0 100644 (file)
--- a/src/compiler/base/cfg2.scm
+++ b/src/compiler/base/cfg2.scm
@@ -155,26 +155,19 @@ USA.
 \f
 ;;;; Noops
 
-(package (cfg-node-tag/noop! cfg-node-tag/noop?)
+(define-integrable (cfg-node-tag/noop! tag)
+  (set-vector-tag-noop! tag true))
 
-(define-export (cfg-node-tag/noop! tag)
-  (vector-tag-put! tag noop-tag-property true))
-
-(define-export (cfg-node-tag/noop? tag)
-  (vector-tag-get tag noop-tag-property))
-
-(define noop-tag-property
-  "noop-tag-property")
-
-)
+(define-integrable (cfg-node-tag/noop? tag)
+  (vector-tag-noop tag))
 
 (define-integrable (cfg-node/noop? node)
   (cfg-node-tag/noop? (tagged-vector/tag node)))
 
 (define noop-node-tag
-  (make-vector-tag snode-tag 'NOOP false))
-
-(cfg-node-tag/noop! noop-node-tag)
+  (let ((tag (make-vector-tag snode-tag 'NOOP false)))
+    (cfg-node-tag/noop! tag)
+    tag))
 
 (define-integrable (make-noop-node)
   (let ((node (make-snode noop-node-tag)))

diff --git a/src/compiler/base/object.scm b/src/compiler/base/object.scm
index 2fb5a44d110df0130f11b2dff910aaee442acaab..c3ea52ec8bbb522e86d3952f5c03d2526bf49d78 100644 (file)
--- a/src/compiler/base/object.scm
+++ b/src/compiler/base/object.scm
@@ -29,16 +29,21 @@ USA.
 (declare (usual-integrations))
 \f
 (define-structure (vector-tag
-                  (constructor %make-vector-tag (parent name index)))
+                  (constructor %make-vector-tag (parent name index noop)))
   (parent false read-only true)
   (name false read-only true)
   (index false read-only true)
   (%unparser false)
   (description false)
-  (method-alist '()))
+  (method-alist '())
+
+  ;; This property was stored in the method alist, but it is used so
+  ;; frequently that it deserves its own slot.
+  (noop false)
+  )
 
 (define make-vector-tag
-  (let ((root-tag (%make-vector-tag false 'OBJECT false)))
+  (let ((root-tag (%make-vector-tag false 'OBJECT false false)))
     (set-vector-tag-%unparser!
      root-tag
      (lambda (state object)
@@ -52,7 +57,10 @@ USA.
                               name
                               (and enumeration
                                    (enumeration/name->index enumeration
-                                                            name)))))
+                                                            name))
+                              ;; Propagate this downward at construction time
+                              ;; to avoid having to crawl upward at use time.
+                              (and parent (vector-tag-noop parent)))))
        (unparser/set-tagged-vector-method! tag tagged-vector/unparse)
        tag))))