From 64dfdb3c7f869f22f3466dae97ba66c7f196522d Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Mon, 31 Oct 2011 08:42:42 -0500 Subject: [PATCH] Change the expansion of reduction-relation so that it generates less code (by expanding into a call to a 30 or so line procedure, instead of putting that code directly into the result of the macro). This produces about a 6x speedup on this reduction-relation (reduction-relation L (--> 0 1) (--> 1 2) ... (--> 99 100)) where L is (define-language L) The time it takes to run "racket r6rs.rkt" in the shell from the directory collects/redex/examples/r6rs speeds up by about 10% (15% with errortrace enabled), in the case where all .zo files are built, except the ones in the r6rs directory. (Also worth noting that "racket -l redex" takes more than 50% of that time.) And the change has no noticeable effect on the time it takes to run r6rs-test.rkt. --- .../redex/private/reduction-semantics.rkt | 93 +++++++++++-------- 1 file changed, 52 insertions(+), 41 deletions(-) diff --git a/collects/redex/private/reduction-semantics.rkt b/collects/redex/private/reduction-semantics.rkt index 30a4a6423d..e6afc9a0f5 100644 --- a/collects/redex/private/reduction-semantics.rkt +++ b/collects/redex/private/reduction-semantics.rkt @@ -964,47 +964,13 @@ [(names/ellipses ...) names/ellipses] [body-code body-code]) #` - (let ([case-id (gensym)]) - (make-rewrite-proc - (λ (lang-id) - (let ([cp (compile-pattern lang-id `side-conditions-rewritten #t)]) - (λ (main-exp exp f other-matches) - (let ([mtchs (match-pattern cp exp)]) - (if mtchs - (let loop ([mtchs mtchs] - [acc other-matches]) - (cond - [(null? mtchs) acc] - [else - (let* ([mtch (car mtchs)] - [bindings (mtch-bindings mtch)] - [really-matched - (term-let ([names/ellipses (lookup-binding bindings 'names)] ...) - body-code)]) - (cond - [really-matched - (for-each - (λ (c) - (let ([r (coverage-relation c)]) - (when (and (reduction-relation? r) - (memf (λ (r) (eq? case-id (rewrite-proc-id r))) - (reduction-relation-make-procs r))) - (cover-case case-id c)))) - (relation-coverage)) - (loop (cdr mtchs) - (map/mt (λ (x) (list name - (if (none? (car x)) - name - (format "~a" (car x))) - (f (cdr x)))) - really-matched acc))] - [else - (loop (cdr mtchs) acc)]))])) - other-matches))))) - name - (λ (lang-id2) `lhs-w/extras) - lhs-source - case-id))))))) + (build-rewrite-proc/leaf `side-conditions-rewritten + (λ (main-exp bindings) + (term-let ([names/ellipses (lookup-binding bindings 'names)] ...) + body-code)) + lhs-source + name + (λ (lang-id2) `lhs-w/extras))))))) (define (process-extras stx orig-name name-table extras) (let* ([the-name #f] @@ -1121,6 +1087,51 @@ (cons (format " ~s" (syntax->datum (car stxs))) (loop (cdr stxs)))]))))) +(define (build-rewrite-proc/leaf side-conditions-rewritten + build-really-matched + lhs-source + name + lhs-w/extras-proc) + (let ([case-id (gensym)]) + (make-rewrite-proc + (λ (lang-id) + (let ([cp (compile-pattern lang-id side-conditions-rewritten #t)]) + (λ (main-exp exp f other-matches) + (let ([mtchs (match-pattern cp exp)]) + (if mtchs + (let loop ([mtchs mtchs] + [acc other-matches]) + (cond + [(null? mtchs) acc] + [else + (let* ([mtch (car mtchs)] + [bindings (mtch-bindings mtch)] + [really-matched (build-really-matched main-exp bindings)]) + (cond + [really-matched + (for-each + (λ (c) + (let ([r (coverage-relation c)]) + (when (and (reduction-relation? r) + (memf (λ (r) (eq? case-id (rewrite-proc-id r))) + (reduction-relation-make-procs r))) + (cover-case case-id c)))) + (relation-coverage)) + (loop (cdr mtchs) + (map/mt (λ (x) (list name + (if (none? (car x)) + name + (format "~a" (car x))) + (f (cdr x)))) + really-matched acc))] + [else + (loop (cdr mtchs) acc)]))])) + other-matches))))) + name + lhs-w/extras-proc + lhs-source + case-id))) + (define (substitute from to pat) (let recur ([p pat]) (syntax-case p (side-condition)