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

redex: added indication of caching for metafunction tracing

Browse Source
This commit is contained in:
Robby Findler 2010-11-07 14:39:39 -06:00
parent c192a1e1f8
commit 38b9b25ae0
3 changed files with 32 additions and 4 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -6,7 +6,7 @@
"fresh.ss"
"loc-wrapper.ss"
"error.ss"
mzlib/trace
racket/trace
racket/contract
(lib "list.ss")
(lib "etc.ss")
@ -1660,12 +1660,20 @@
(log-coverage (cdr cache-ref))
(car cache-ref)])))]
[ot (current-trace-print-args)]
[otr (current-trace-print-results)]
[traced-metafunc (lambda (exp)
(if (or (eq? (current-traced-metafunctions) 'all)
(memq name (current-traced-metafunctions)))
(parameterize ([current-trace-print-args
(λ (name args kws kw-args level)
(ot name (car args) kws kw-args level))])
(if (eq? not-in-cache (hash-ref cache exp not-in-cache))
(display " ")
(display "c"))
(ot name (car args) kws kw-args level))]
[current-trace-print-results
(λ (name results level)
(display " ")
(otr name results level))])
(trace-call name metafunc exp))
(metafunc exp)))])
traced-metafunc))

6
collects/redex/redex.scrbl
View File

@ -1083,6 +1083,12 @@ Controls which metafunctions are currently being traced. If it is
@racket['all], all of them are. Otherwise, the elements of the list
name the metafunctions to trace.
The tracing looks just like the tracing done by the @racketmodname[racket/trace]
library, except that the first column printed by each traced call indicate
if this call to the metafunction is cached. Specifically, a @tt{c} is printed
in the first column if the result is just returned from the cache and a
space is printed if the metafunction call is actually performed.
Defaults to @racket['()].
}

18
collects/redex/tests/tl-test.rkt
View File

@ -757,14 +757,28 @@
[current-traced-metafunctions 'all]
[print-as-expression #f])
(term (f 1)))
(test (get-output-string sp) ">(f 1)\n<0\n"))
(test (get-output-string sp) "c>(f 1)\n <0\n"))
(let ([sp (open-output-string)])
(parameterize ([current-output-port sp]
[current-traced-metafunctions '(f)]
[print-as-expression #f])
(term (f 1)))
(test (get-output-string sp) ">(f 1)\n<0\n")))
(test (get-output-string sp) "c>(f 1)\n <0\n"))
(define-metafunction empty-language
[(g (any)) ((g any) (g any))]
[(g 1) 1])
(let ([sp (open-output-string)])
(parameterize ([current-output-port sp]
[current-traced-metafunctions '(g)]
[print-as-expression #f])
(term (g (1))))
(test (get-output-string sp) " >(g (1))\n > (g 1)\n < 1\nc> (g 1)\n < 1\n <(1 1)\n"))
)
(let ()
(define-language var-lang [(x y z w) variable])