Use cached predicate dispatchers only where tagging is ubiquitous.

diff --git a/src/runtime/predicate-dispatch.scm b/src/runtime/predicate-dispatch.scm
index 842e62de64ca5ea97a471c3a4989c3e90bd8bb26..70860f4790eabc45a95bf9d6c52797bb9c57a0e1 100644 (file)
--- a/src/runtime/predicate-dispatch.scm
+++ b/src/runtime/predicate-dispatch.scm
@@ -87,9 +87,15 @@ USA.
   (make-predicate-dispatcher name arity simple-handler-set))
 
 (define (standard-predicate-dispatcher name arity)
-  (make-predicate-dispatcher name arity cached-most-specific-handler-set))
+  (make-predicate-dispatcher name arity most-specific-handler-set))
 
 (define (chaining-predicate-dispatcher name arity)
+  (make-predicate-dispatcher name arity chaining-handler-set))
+
+(define (cached-standard-predicate-dispatcher name arity)
+  (make-predicate-dispatcher name arity cached-most-specific-handler-set))
+
+(define (cached-chaining-predicate-dispatcher name arity)
   (make-predicate-dispatcher name arity cached-chaining-handler-set))
 \f
 (define-record-type <metadata>

diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index 2615bb5897c8796713f3099da801229517f14f8d..98194fd57ac58d256c3116b5170c4ef799809952 100644 (file)
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -1902,6 +1902,8 @@ USA.
   (files "predicate-dispatch")
   (parent (runtime))
   (export ()
+         cached-chaining-predicate-dispatcher
+         cached-standard-predicate-dispatcher
          chaining-predicate-dispatcher
          define-predicate-dispatch-default-handler
          define-predicate-dispatch-handler

diff --git a/src/runtime/syntax-items.scm b/src/runtime/syntax-items.scm
index 874724ffa0b301412122f3a3d53a40fd758edf1e..2017e509f4a8154a8a21733ca635e1aa7d12de16 100644 (file)
--- a/src/runtime/syntax-items.scm
+++ b/src/runtime/syntax-items.scm
@@ -203,9 +203,9 @@ USA.
 (add-boot-init!
  (lambda ()
    (set! compile-item
-        (standard-predicate-dispatcher 'compile-item 1))
+        (cached-standard-predicate-dispatcher 'compile-item 1))
    (set! compile-expr-item
-        (standard-predicate-dispatcher 'compile-expr-item 1))
+        (cached-standard-predicate-dispatcher 'compile-expr-item 1))
    (run-deferred-boot-actions 'define-item-compiler)))
 
 (define (define-item-compiler predicate compiler #!optional expr-compiler)

diff --git a/src/runtime/syntax-rename.scm b/src/runtime/syntax-rename.scm
index 8029925b73bed8917a0af8caf7c70eeccfc01982..0ba38203bee905050cfaa75c43f66c494d969447 100644 (file)
--- a/src/runtime/syntax-rename.scm
+++ b/src/runtime/syntax-rename.scm
@@ -188,7 +188,7 @@ USA.
                    (get-subexpressions expression)))))
 
    (set! compute-substitution
-        (standard-predicate-dispatcher 'compute-substitution 2))
+        (cached-standard-predicate-dispatcher 'compute-substitution 2))
 
    (define-predicate-dispatch-default-handler compute-substitution
      (lambda (expression mark-safe!)
@@ -300,7 +300,7 @@ USA.
             (get-subexpressions expression)))))
 
    (set! alpha-substitute
-        (standard-predicate-dispatcher 'alpha-substitute 2))
+        (cached-standard-predicate-dispatcher 'alpha-substitute 2))
 
    (define-predicate-dispatch-default-handler alpha-substitute
      (lambda (substitution expression)

diff --git a/src/xml/xml-output.scm b/src/xml/xml-output.scm
index 1a5abe3efd3b2d63d8b9182767b5aecb8cb92918..0512be4705089fe05fe3f1176575b562c75cd76c 100644 (file)
--- a/src/xml/xml-output.scm
+++ b/src/xml/xml-output.scm
@@ -122,7 +122,7 @@ USA.
        (ctx-start-col ctx)))
 \f
 (define %write-xml
-  (standard-predicate-dispatcher '%write-xml 2))
+  (cached-standard-predicate-dispatcher '%write-xml 2))
 
 (define-predicate-dispatch-handler %write-xml (list xml-document? ctx?)
   (lambda (document ctx)