From d79ae5a1af3c7f2f33469ee5d1cafa9a1c72f0a0 Mon Sep 17 00:00:00 2001
From: Joe Marshall <eval.apply@gmail.com>
Date: Sat, 14 Jan 2012 14:01:04 -0800
Subject: [PATCH] Make noop-tag-property a slot in the vector tag.

---
 src/compiler/base/cfg2.scm   | 21 +++++++--------------
 src/compiler/base/object.scm | 16 ++++++++++++----
 2 files changed, 19 insertions(+), 18 deletions(-)

diff --git a/src/compiler/base/cfg2.scm b/src/compiler/base/cfg2.scm
index ba9e8bcf0..48e1b64ae 100644
--- a/src/compiler/base/cfg2.scm
+++ b/src/compiler/base/cfg2.scm
@@ -155,26 +155,19 @@ USA.
 
 ;;;; 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 2fb5a44d1..c3ea52ec8 100644
--- a/src/compiler/base/object.scm
+++ b/src/compiler/base/object.scm
@@ -29,16 +29,21 @@ USA.
 (declare (usual-integrations))
 
 (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))))
 
-- 
2.25.1