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

added metafunction result caching

Browse Source 
svn: r11883
This commit is contained in:
Robby Findler 2008-09-26 16:13:03 +00:00
parent c0bc68f35b
commit d1b2bf63c7
2 changed files with 44 additions and 31 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

70
collects/redex/private/reduction-semantics.ss
View File

@ -1046,39 +1046,47 @@
[codom-compiled-pattern (compile-pattern lang codom-contract-pat #f)])
(values
(wrap
(letrec ([metafunc
(letrec ([cache (make-hash)]
[not-in-cache (gensym)]
[metafunc
(λ (exp)
(when dom-compiled-pattern
(unless (match-pattern dom-compiled-pattern exp)
(redex-error name
"~s is not in my domain"
`(,name ,@exp))))
(let loop ([patterns compiled-patterns]
[rhss (append old-rhss rhss)]
[num (- (length old-cps))])
(let ([cache-ref (hash-ref cache exp not-in-cache)])
(cond
[(null? patterns)
(redex-error name "no clauses matched for ~s" `(,name . ,exp))]
[else
(let ([pattern (car patterns)]
[rhs (car rhss)])
(let ([mtchs (match-pattern pattern exp)])
(cond
[(not mtchs) (loop (cdr patterns)
(cdr rhss)
(+ num 1))]
[(not (null? (cdr mtchs)))
(redex-error name "~a matched ~s ~a different ways"
(if (< num 0)
"a clause from an extended metafunction"
(format "clause ~a" num))
`(,name ,@exp)
(length mtchs))]
[else
(let ([ans (rhs metafunc (mtch-bindings (car mtchs)))])
(unless (match-pattern codom-compiled-pattern ans)
(redex-error name "codomain test failed for ~s, call was ~s" ans `(,name ,@exp)))
ans)])))])))])
[(eq? cache-ref not-in-cache)
(when dom-compiled-pattern
(unless (match-pattern dom-compiled-pattern exp)
(redex-error name
"~s is not in my domain"
`(,name ,@exp))))
(let loop ([patterns compiled-patterns]
[rhss (append old-rhss rhss)]
[num (- (length old-cps))])
(cond
[(null? patterns)
(redex-error name "no clauses matched for ~s" `(,name . ,exp))]
[else
(let ([pattern (car patterns)]
[rhs (car rhss)])
(let ([mtchs (match-pattern pattern exp)])
(cond
[(not mtchs) (loop (cdr patterns)
(cdr rhss)
(+ num 1))]
[(not (null? (cdr mtchs)))
(redex-error name "~a matched ~s ~a different ways"
(if (< num 0)
"a clause from an extended metafunction"
(format "clause ~a" num))
`(,name ,@exp)
(length mtchs))]
[else
(let ([ans (rhs metafunc (mtch-bindings (car mtchs)))])
(unless (match-pattern codom-compiled-pattern ans)
(redex-error name "codomain test failed for ~s, call was ~s" ans `(,name ,@exp)))
(hash-set! cache exp ans)
ans)])))]))]
[else
cache-ref])))])
metafunc)
compiled-patterns
rhss)

5
collects/redex/redex.scrbl
View File

@ -840,6 +840,11 @@ Raises an exception recognized by @scheme[exn:fail:redex?] if
no clauses match, if one of the clauses matches multiple ways, or
if the contract is violated.
Note that metafunctions are assumed to always return the same results
for the same inputs, and their results are cached. Accordingly, if a
metafunction is called with the same inputs twice, then its body is
only evaluated a single time.
As an example, these metafunctions finds the free variables in
an expression in the lc-lang above: