suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Change the expansion of reduction-relation so that it generates less code

Browse Source 
(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.
This commit is contained in:
Robby Findler 2011-10-31 08:42:42 -05:00
parent 41f68af64a
commit 64dfdb3c7f
1 changed files with 52 additions and 41 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

93
collects/redex/private/reduction-semantics.rkt
View File

@ -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)