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)]) [codom-compiled-pattern (compile-pattern lang codom-contract-pat #f)])
(values (values
(wrap (wrap
(letrec ([metafunc (letrec ([cache (make-hash)]
[not-in-cache (gensym)]
[metafunc
(λ (exp) (λ (exp)
(when dom-compiled-pattern (let ([cache-ref (hash-ref cache exp not-in-cache)])
(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 (cond
[(null? patterns) [(eq? cache-ref not-in-cache)
(redex-error name "no clauses matched for ~s" `(,name . ,exp))] (when dom-compiled-pattern
[else (unless (match-pattern dom-compiled-pattern exp)
(let ([pattern (car patterns)] (redex-error name
[rhs (car rhss)]) "~s is not in my domain"
(let ([mtchs (match-pattern pattern exp)]) `(,name ,@exp))))
(cond (let loop ([patterns compiled-patterns]
[(not mtchs) (loop (cdr patterns) [rhss (append old-rhss rhss)]
(cdr rhss) [num (- (length old-cps))])
(+ num 1))] (cond
[(not (null? (cdr mtchs))) [(null? patterns)
(redex-error name "~a matched ~s ~a different ways" (redex-error name "no clauses matched for ~s" `(,name . ,exp))]
(if (< num 0) [else
"a clause from an extended metafunction" (let ([pattern (car patterns)]
(format "clause ~a" num)) [rhs (car rhss)])
`(,name ,@exp) (let ([mtchs (match-pattern pattern exp)])
(length mtchs))] (cond
[else [(not mtchs) (loop (cdr patterns)
(let ([ans (rhs metafunc (mtch-bindings (car mtchs)))]) (cdr rhss)
(unless (match-pattern codom-compiled-pattern ans) (+ num 1))]
(redex-error name "codomain test failed for ~s, call was ~s" ans `(,name ,@exp))) [(not (null? (cdr mtchs)))
ans)])))])))]) (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) metafunc)
compiled-patterns compiled-patterns
rhss) 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 no clauses match, if one of the clauses matches multiple ways, or
if the contract is violated. 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 As an example, these metafunctions finds the free variables in
an expression in the lc-lang above: an expression in the lc-lang above: