From ffefa004080037a8d0d52301fff1b19d91443bed Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Wed, 14 Mar 2018 21:29:03 -0700 Subject: [PATCH] Use cached predicate dispatchers only where tagging is ubiquitous. --- src/runtime/predicate-dispatch.scm | 8 +++++++- src/runtime/runtime.pkg | 2 ++ src/runtime/syntax-items.scm | 4 ++-- src/runtime/syntax-rename.scm | 4 ++-- src/xml/xml-output.scm | 2 +- 5 files changed, 14 insertions(+), 6 deletions(-) diff --git a/src/runtime/predicate-dispatch.scm b/src/runtime/predicate-dispatch.scm index 842e62de6..70860f479 100644 --- 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)) (define-record-type diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg index 2615bb589..98194fd57 100644 --- 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 874724ffa..2017e509f 100644 --- 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 8029925b7..0ba38203b 100644 --- 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 1a5abe3ef..0512be470 100644 --- a/src/xml/xml-output.scm +++ b/src/xml/xml-output.scm @@ -122,7 +122,7 @@ USA. (ctx-start-col ctx))) (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) -- 2.25.1