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

Added trace-define, trace-let, trace-lambda

Browse Source 
In racket/collects/racket/trace.rkt
This commit is contained in:
William J. Bowman 2013-12-14 13:26:50 -05:00 committed by Asumu Takikawa
parent 3905334f28
commit c6b3f337e9
3 changed files with 425 additions and 258 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

84
pkgs/racket-pkgs/racket-doc/scribblings/reference/trace.scrbl
View File

@ -3,7 +3,8 @@
scribble/eval) scribble/eval)
@(begin (define ev (make-base-eval)) @(begin (define ev (make-base-eval))
(ev '(require racket/trace))) (ev '(require racket/trace))
(ev '(require (for-syntax racket/base))))
@title{Tracing} @title{Tracing}
@ -49,6 +50,79 @@ The result of a @racket[trace] expression is @|void-const|.
} }
@defform*[((trace-define id expr)
(trace-define (head args) body ...+))]{
The @racket[trace-define] form is short-hand for first defining a
function then tracing it. This form supports all @racket[define] forms.
@examples[#:eval ev
(trace-define (f x) (if (zero? x) 0 (add1 (f (sub1 x)))))
(f 5)
]
@examples[#:eval ev
(trace-define ((+n n) x) (+ n x))
(map (+n 5) (list 1 3 4))
]}
@defform*[((trace-define-syntax id expr)
(trace-define-syntax (head args) body ...+))]{
The @racket[trace-define-syntax] form is short-hand for first defining a
macro then tracing it. This form supports all @racket[define-syntax] forms.
For example:
@examples[#:eval ev
(trace-define-syntax fact
(syntax-rules ()
[(_ x) 120]))
(fact 5)
]
By default, @racket[trace] prints out syntax objects when tracing a
macro. This can result in too much output if you do not need to see,
e.g., source information. To get more readable output, try this:
@examples[#:eval ev
(require (for-syntax racket/trace))
(begin-for-syntax
(current-trace-print-args
(let ([ctpa (current-trace-print-args)])
(lambda (s l kw l2 n)
(ctpa s (map syntax->datum l) kw l2 n))))
(current-trace-print-results
(let ([ctpr (current-trace-print-results)])
(lambda (s l n)
(ctpr s (map syntax->datum l) n)))))
(trace-define-syntax fact
(syntax-rules ()
[(_ x) #'120]))
(fact 5)]}
@defform[(trace-lambda [#:name id] args expr)]{
The @racket[trace-lambda] form enables tracing an anonymous function. This
form will attempt to infer a name using
@racket[syntax-local-infer-name], or a name can be specified using the
optional @racket[#:name] argument. A syntax error is raised if a name
is not given and a name cannot be inferred.
@examples[#:eval ev
((trace-lambda (x) 120) 5)]}
@defform[(trace-let id ([arg expr] ...+) body ...+)]{
The @racket[trace-let] form enables tracing a named let.
@examples[#:eval ev
(trace-let f ([x 5])
(if (zero? x)
1
(* x (f (sub1 x)))))]}
@defform[(untrace id ...)]{ @defform[(untrace id ...)]{
Undoes the effects of the @racket[trace] form for each @racket[id], Undoes the effects of the @racket[trace] form for each @racket[id],
@ -79,7 +153,7 @@ trace information during the call, as described above in the docs for
} }
@defparam[current-trace-print-args trace-print-args @defparam[current-trace-print-args trace-print-args
(-> symbol? (-> symbol?
list? list?
(listof keyword?) (listof keyword?)
@ -94,7 +168,7 @@ number indicating the depth of the call.
} }
@defparam[current-trace-print-results trace-print-results @defparam[current-trace-print-results trace-print-results
(-> symbol? (-> symbol?
list? list?
number? number?
@ -110,7 +184,7 @@ results, and a number indicating the depth of the call.
This string is used by the default value of @racket[current-trace-print-args] This string is used by the default value of @racket[current-trace-print-args]
indicating that the current line is showing the a call to a indicating that the current line is showing the a call to a
traced function. traced function.
It defaults to @racket[">"]. It defaults to @racket[">"].
} }
@ -119,7 +193,7 @@ results, and a number indicating the depth of the call.
This string is used by the default value of @racket[current-trace-print-results] This string is used by the default value of @racket[current-trace-print-results]
indicating that the current line is showing the result indicating that the current line is showing the result
of a traced call. of a traced call.
It defaults to @racket["<"]. It defaults to @racket["<"].
} }

39
pkgs/racket-pkgs/racket-test/tests/racket/trace.rktl
View File

@ -69,4 +69,43 @@
(list ">(f (1 2 3) #:q #&18)" (list ">(f (1 2 3) #:q #&18)"
"<((1 2 3) 1)"))) "<((1 2 3) 1)")))
(test
(list ">(verbose-fact 2)"
"> (verbose-fact 1)"
"> >(verbose-fact 0)"
"< <1"
"> >(verbose-fact 0)"
"< <1"
"< 1"
"> (verbose-fact 1)"
"> >(verbose-fact 0)"
"< <1"
"> >(verbose-fact 0)"
"< <1"
"< 1"
"<2")
'trace-define
(trace-output
(trace-define (verbose-fact x)
(if (zero? x)
(begin (displayln 1) 1)
(begin (displayln (* x (verbose-fact (sub1 x))))
(* x (verbose-fact (sub1 x))))))
(parameterize ([current-output-port (open-output-nowhere)]) (verbose-fact 2))))
(test
(list ">(fact 120)"
"<120")
'trace-lambda-named
(trace-output
((trace-lambda #:name fact (x) x) 120)))
(let ([tout (trace-output ((trace-lambda (x) x) 120))])
(local-require racket/match)
(test #t
'trace-lambda-anonymous
(match tout
[(list (pregexp #px">\\(.+\\.rktl?:\\d+:\\d+ 120\\)") "<120") #t]
[_ #f])))
(report-errs) (report-errs)

560
racket/collects/racket/trace.rkt
View File

@ -1,57 +1,58 @@
#lang racket/base #lang racket/base
(require racket/pretty (module trace-et-al racket/base
(for-syntax racket/base)) (require racket/pretty
(for-syntax racket/base))
(provide trace untrace (provide trace untrace
current-trace-print-results current-trace-print-results
current-trace-print-args current-trace-print-args
trace-call trace-call
current-trace-notify current-trace-notify
current-prefix-out current-prefix-in) current-prefix-out current-prefix-in)
(define max-dash-space-depth 10) (define max-dash-space-depth 10)
(define number-nesting-depth 6) (define number-nesting-depth 6)
(define current-prefix-out (make-parameter "<")) (define current-prefix-out (make-parameter "<"))
(define current-prefix-in (make-parameter ">")) (define current-prefix-in (make-parameter ">"))
(define (as-spaces s) (define (as-spaces s)
(make-string (string-length s) #\space)) (make-string (string-length s) #\space))
(define-struct prefix-entry (for-first for-rest)) (define-struct prefix-entry (for-first for-rest))
(define prefixes (make-hash)) (define prefixes (make-hash))
(define (lookup-prefix n label) (define (lookup-prefix n label)
(hash-ref prefixes (cons n label) (lambda () #f))) (hash-ref prefixes (cons n label) (lambda () #f)))
(define (insert-prefix n label first rest) (define (insert-prefix n label first rest)
(hash-set! prefixes (cons n label) (make-prefix-entry first rest))) (hash-set! prefixes (cons n label) (make-prefix-entry first rest)))
(define (construct-prefixes level label) (define (construct-prefixes level label)
(let loop ([n level] (let loop ([n level]
[first (list label)] [first (list label)]
[rest '(" ")]) [rest '(" ")])
(if (>= n max-dash-space-depth) (if (>= n max-dash-space-depth)
(let-values ([(pre-first pre-rest) (let-values ([(pre-first pre-rest)
(build-prefixes number-nesting-depth label)]) (build-prefixes number-nesting-depth label)])
(let ((s (number->string level))) (let ((s (number->string level)))
(values (values
(string-append pre-first "[" s "] ") (string-append pre-first "[" s "] ")
(string-append pre-rest " " (as-spaces s) " ")))) (string-append pre-rest " " (as-spaces s) " "))))
(cond (cond
[(= n 0) (values (apply string-append (reverse first)) [(= n 0) (values (apply string-append (reverse first))
(apply string-append (reverse rest)))] (apply string-append (reverse rest)))]
[(= n 1) (loop (- n 1) [(= n 1) (loop (- n 1)
(cons '" " first) (cons '" " first)
(cons '" " rest))] (cons '" " rest))]
[else (loop (- n 2) [else (loop (- n 2)
(cons (format " ~a" label) first) (cons (format " ~a" label) first)
(cons " " rest))])))) (cons " " rest))]))))
(define (build-prefixes level label) (define (build-prefixes level label)
(let ([p (lookup-prefix level label)]) (let ([p (lookup-prefix level label)])
(if p (if p
(values (prefix-entry-for-first p) (values (prefix-entry-for-first p)
(prefix-entry-for-rest p)) (prefix-entry-for-rest p))
(let-values (((first rest) (let-values (((first rest)
@ -59,237 +60,290 @@
(insert-prefix level label first rest) (insert-prefix level label first rest)
(values first rest))))) (values first rest)))))
(define current-trace-notify (define current-trace-notify
(make-parameter (lambda (s) (make-parameter (lambda (s)
(display s) (display s)
(newline)) (newline))
(lambda (p) (lambda (p)
(unless (and (procedure? p) (unless (and (procedure? p)
(procedure-arity-includes? p 1)) (procedure-arity-includes? p 1))
(raise-argument-error 'current-trace-notify (raise-argument-error 'current-trace-notify
"(any/c . -> . any)" "(any/c . -> . any)"
p)) p))
p))) p)))
(define (as-trace-notify thunk) (define (as-trace-notify thunk)
(let ([p (open-output-bytes)]) (let ([p (open-output-bytes)])
(parameterize ([current-output-port p]) (parameterize ([current-output-port p])
(thunk)) (thunk))
(let ([b (get-output-bytes p #t 0 (let ([b (get-output-bytes p #t 0
;; drop newline: ;; drop newline:
(sub1 (file-position p)))]) (sub1 (file-position p)))])
((current-trace-notify) (bytes->string/utf-8 b))))) ((current-trace-notify) (bytes->string/utf-8 b)))))
(define -:trace-print-args (define -:trace-print-args
(lambda (name args kws kw-vals level) (lambda (name args kws kw-vals level)
(as-trace-notify (as-trace-notify
(lambda () (lambda ()
((current-trace-print-args) name args kws kw-vals level))))) ((current-trace-print-args) name args kws kw-vals level)))))
(struct plain (val) (struct plain (val)
#:property prop:custom-write (lambda (p port mode) #:property prop:custom-write (lambda (p port mode)
(write (plain-val p) port))) (write (plain-val p) port)))
(define current-trace-print-args (define current-trace-print-args
(make-parameter (make-parameter
(lambda (name args kws kw-vals level) (lambda (name args kws kw-vals level)
(let-values (((first rest) (let-values (((first rest)
(build-prefixes level (current-prefix-in)))) (build-prefixes level (current-prefix-in))))
(parameterize ((pretty-print-print-line (parameterize ((pretty-print-print-line
(lambda (n port offset width) (lambda (n port offset width)
(display (display
(if n
(if (zero? n) first (format "\n~a" rest))
"\n")
port)
(if n
(if (zero? n)
(string-length first)
(string-length rest))
0))))
;; Printing the function call in a way that adapts to
;; different value printing --- currently a hack
(cond
[(print-as-expression)
;; In expression mode, represent a function call as a
;; transparent structure, so that it prints as a constructor
;; application. Also, protect keywords for keyword arguments
;; so that they print without quoting.
(let ([args (append args
(apply append (map (lambda (kw val)
(list (plain kw) val))
kws
kw-vals)))])
(let-values ([(struct: make- ? -ref -set!)
(make-struct-type name #f
(length args) 0 #f
null #f #f null #f
name)])
(pretty-print (apply make- args))))]
[else
;; In non-expression mode, just use `write':
(pretty-write (append (cons name args)
(apply append (map list kws kw-vals))))]))))))
(define -:trace-print-results
(lambda (name results level)
(as-trace-notify
(lambda ()
((current-trace-print-results) name results level)))))
(define current-trace-print-results
(make-parameter
(lambda (name results level)
(let-values (((first rest)
(build-prefixes level (current-prefix-out))))
(parameterize ((pretty-print-print-line
(lambda (n port offset width)
(display
(if n
(if (zero? n) first (format "\n~a" rest))
"\n")
port)
(if n
(if (zero? n)
(string-length first)
(string-length rest))
0))))
(cond
((null? results)
(pretty-display "*** no values ***"))
((null? (cdr results))
(pretty-print (car results)))
(else
(pretty-print (car results))
(parameterize ((pretty-print-print-line
(lambda (n port offset width)
(display
(if n
(if (zero? n) rest (format "\n~a" rest))
"\n")
port)
(if n (if n
(string-length rest) (if (zero? n) first (format "\n~a" rest))
0)))) "\n")
(for-each pretty-print (cdr results)))))))))) port)
(if n
(if (zero? n)
(string-length first)
(string-length rest))
0))))
;; Printing the function call in a way that adapts to
;; different value printing --- currently a hack
(cond
[(print-as-expression)
;; In expression mode, represent a function call as a
;; transparent structure, so that it prints as a constructor
;; application. Also, protect keywords for keyword arguments
;; so that they print without quoting.
(let ([args (append args
(apply append (map (lambda (kw val)
(list (plain kw) val))
kws
kw-vals)))])
(let-values ([(struct: make- ? -ref -set!)
(make-struct-type name #f
(length args) 0 #f
null #f #f null #f
name)])
(pretty-print (apply make- args))))]
[else
;; In non-expression mode, just use `write':
(pretty-write (append (cons name args)
(apply append (map list kws kw-vals))))]))))))
(define -:trace-print-results
(lambda (name results level)
(as-trace-notify
(lambda ()
((current-trace-print-results) name results level)))))
(define current-trace-print-results
(make-parameter
(lambda (name results level)
(let-values (((first rest)
(build-prefixes level (current-prefix-out))))
(parameterize ((pretty-print-print-line
(lambda (n port offset width)
(display
(if n
(if (zero? n) first (format "\n~a" rest))
"\n")
port)
(if n
(if (zero? n)
(string-length first)
(string-length rest))
0))))
(cond
((null? results)
(pretty-display "*** no values ***"))
((null? (cdr results))
(pretty-print (car results)))
(else
(pretty-print (car results))
(parameterize ((pretty-print-print-line
(lambda (n port offset width)
(display
(if n
(if (zero? n) rest (format "\n~a" rest))
"\n")
port)
(if n
(string-length rest)
0))))
(for-each pretty-print (cdr results))))))))))
;; A traced-proc struct instance acts like a procedure, ;; A traced-proc struct instance acts like a procedure,
;; but preserves the original, too. ;; but preserves the original, too.
(define-values (struct:traced-proc make-traced-proc traced-proc? traced-proc-ref traced-proc-set!) (define-values (struct:traced-proc make-traced-proc traced-proc? traced-proc-ref traced-proc-set!)
(make-struct-type 'traced-proc #f 2 0 #f (make-struct-type 'traced-proc #f 2 0 #f
(list (cons prop:procedure 0)) (list (cons prop:procedure 0))
(current-inspector) #f (list 0 1))) (current-inspector) #f (list 0 1)))
;; Install traced versions of a given set of procedures. The traced ;; Install traced versions of a given set of procedures. The traced
;; versions are also given, so that they can be constructed to have ;; versions are also given, so that they can be constructed to have
;; a nice name. ;; a nice name.
(define (do-trace ids procs setters traced-procs) (define (do-trace ids procs setters traced-procs)
(for-each (lambda (id proc) (for-each (lambda (id proc)
(unless (procedure? proc) (unless (procedure? proc)
(error 'trace (error 'trace
"the value of ~s is not a procedure: ~e" id proc))) "the value of ~s is not a procedure: ~e" id proc)))
ids procs) ids procs)
(for-each (lambda (proc setter traced-proc) (for-each (lambda (proc setter traced-proc)
(unless (traced-proc? proc) (unless (traced-proc? proc)
(setter (make-traced-proc (setter (make-traced-proc
(let-values ([(a) (procedure-arity proc)] (let-values ([(a) (procedure-arity proc)]
[(req allowed) (procedure-keywords proc)]) [(req allowed) (procedure-keywords proc)])
(procedure-reduce-keyword-arity traced-proc (procedure-reduce-keyword-arity traced-proc
a a
req req
allowed)) allowed))
proc)))) proc))))
procs setters traced-procs)) procs setters traced-procs))
;; Key used for a continuation mark to indicate ;; Key used for a continuation mark to indicate
;; the nesting depth: ;; the nesting depth:
(define -:trace-level-key (gensym)) (define -:trace-level-key (gensym))
(define trace-call (define trace-call
(make-keyword-procedure (make-keyword-procedure
(lambda (id f kws vals . args) (lambda (id f kws vals . args)
(do-traced id args kws vals f)) (do-traced id args kws vals f))
(lambda (id f . args) (lambda (id f . args)
(do-traced id args '() '() f)))) (do-traced id args '() '() f))))
;; Apply a traced procedure to arguments, printing arguments ;; Apply a traced procedure to arguments, printing arguments
;; and results. We set and inspect the -:trace-level-key continuation ;; and results. We set and inspect the -:trace-level-key continuation
;; mark a few times to detect tail calls. ;; mark a few times to detect tail calls.
(define (do-traced id args kws kw-vals real-value) (define (do-traced id args kws kw-vals real-value)
(let* ([levels (continuation-mark-set->list (let* ([levels (continuation-mark-set->list
(current-continuation-marks) (current-continuation-marks)
-:trace-level-key)] -:trace-level-key)]
[level (if (null? levels) 0 (car levels))]) [level (if (null? levels) 0 (car levels))])
;; Tentatively push the new depth level: ;; Tentatively push the new depth level:
(with-continuation-mark -:trace-level-key (add1 level) (with-continuation-mark -:trace-level-key (add1 level)
;; Check for tail-call => car of levels replaced, ;; Check for tail-call => car of levels replaced,
;; which means that the first two new marks are ;; which means that the first two new marks are
;; not consecutive: ;; not consecutive:
(let ([new-levels (continuation-mark-set->list (let ([new-levels (continuation-mark-set->list
(current-continuation-marks) (current-continuation-marks)
-:trace-level-key)]) -:trace-level-key)])
(if (and (pair? (cdr new-levels)) (if (and (pair? (cdr new-levels))
(> (car new-levels) (add1 (cadr new-levels)))) (> (car new-levels) (add1 (cadr new-levels))))
;; Tail call: reset level and just call real-value. ;; Tail call: reset level and just call real-value.
;; (This is in tail position to the call to `do-traced'.) ;; (This is in tail position to the call to `do-traced'.)
;; We don't print the results, because the original ;; We don't print the results, because the original
;; call will. ;; call will.
(begin (begin
(-:trace-print-args id args kws kw-vals (sub1 level)) (-:trace-print-args id args kws kw-vals (sub1 level))
(with-continuation-mark -:trace-level-key (car levels) (with-continuation-mark -:trace-level-key (car levels)
(if (null? kws) (if (null? kws)
(apply real-value args) (apply real-value args)
(keyword-apply real-value kws kw-vals args)))) (keyword-apply real-value kws kw-vals args))))
;; Not a tail call; push the old level, again, to ensure ;; Not a tail call; push the old level, again, to ensure
;; that when we push the new level, we have consecutive ;; that when we push the new level, we have consecutive
;; levels associated with the mark (i.e., set up for ;; levels associated with the mark (i.e., set up for
;; tail-call detection the next time around): ;; tail-call detection the next time around):
(begin (begin
(-:trace-print-args id args kws kw-vals level) (-:trace-print-args id args kws kw-vals level)
(with-continuation-mark -:trace-level-key level (with-continuation-mark -:trace-level-key level
(call-with-values (call-with-values
(lambda () (lambda ()
(with-continuation-mark -:trace-level-key (add1 level) (with-continuation-mark -:trace-level-key (add1 level)
(if (null? kws) (if (null? kws)
(apply real-value args) (apply real-value args)
(keyword-apply real-value kws kw-vals args)))) (keyword-apply real-value kws kw-vals args))))
(lambda results (lambda results
(flush-output) (flush-output)
;; Print the results: ;; Print the results:
(-:trace-print-results id results level) (-:trace-print-results id results level)
;; Return the results: ;; Return the results:
(apply values results)))))))))) (apply values results))))))))))
(define-for-syntax (check-ids stx ids) (define-for-syntax (check-ids stx ids)
(for ([id (in-list (syntax->list ids))]) (for ([id (in-list (syntax->list ids))])
(unless (identifier? id) (unless (identifier? id)
(raise-syntax-error #f "not an identifier" stx id))) (raise-syntax-error #f "not an identifier" stx id)))
#t) #t)
(define-syntax (trace stx) (define-syntax (trace stx)
(syntax-case stx () (syntax-case stx ()
[(_ id ...) (check-ids stx #'(id ...)) [(_ id ...) (check-ids stx #'(id ...))
(with-syntax ([(tid ...) (with-syntax ([(tid ...)
(for/list ([id (in-list (syntax->list #'(id ...)))]) (for/list ([id (in-list (syntax->list #'(id ...)))])
(let ([tid (format "traced-~a" (syntax-e id))]) (let ([tid (format "traced-~a" (syntax-e id))])
(datum->syntax id (string->symbol tid) #f)))]) (datum->syntax id (string->symbol tid) #f)))])
#'(do-trace #'(do-trace
'(id ...) '(id ...)
(list id ...) (list id ...)
(list (lambda (v) (set! id v)) ...) (list (lambda (v) (set! id v)) ...)
(list (let* ([real-value id] (list (let* ([real-value id]
[tid (make-keyword-procedure [tid (make-keyword-procedure
(lambda (kws vals . args) (lambda (kws vals . args)
(do-traced 'id args kws vals real-value)) (do-traced 'id args kws vals real-value))
(lambda args (lambda args
(do-traced 'id args null null real-value)))]) (do-traced 'id args null null real-value)))])
tid) tid)
...)))])) ...)))]))
(define-syntax (untrace stx) (define-syntax (untrace stx)
(syntax-case stx () (syntax-case stx ()
[(_ id ...) (check-ids stx #'(id ...)) [(_ id ...) (check-ids stx #'(id ...))
#'(begin (when (traced-proc? id) #'(begin (when (traced-proc? id)
(set! id (traced-proc-ref id 1))) (set! id (traced-proc-ref id 1)))
...)])) ...)])))
(module chez-like racket/base
(require
(only-in (submod ".." trace-et-al) trace)
(for-syntax
racket/base
syntax/define
syntax/name
syntax/parse
(only-in (submod ".." trace-et-al) trace)))
(provide trace-define trace-lambda trace-let trace-define-syntax)
(define-syntax (trace-define stx)
(syntax-case stx ()
[(_ e ...)
(let-values ([(name def) (normalize-definition stx #'lambda)])
#`(begin (define #,name #,def) (trace #,name)))]))
(define-syntax trace-let
(syntax-rules ()
[(_ name ([x* e*] ...) body ...)
((letrec ([name (lambda (x* ...) body ...)]) (trace name) name)
e* ...)]))
(define-syntax (trace-lambda stx)
(define (infer-name-or-error)
(or (syntax-local-infer-name stx)
(raise-syntax-error
'trace-lambda
"Could not infer name; give a name explicitly using #:name"
stx)))
(syntax-parse stx
[(_ (~optional (~seq #:name name:id) #:defaults ([name #`#,(infer-name-or-error)])) args body:expr ...)
#'(let ([name (lambda args body ...)]) (trace name) name)]))
(define-syntax (trace-define-syntax stx)
(syntax-case stx ()
[(_ e ...)
(let-values ([(name def) (normalize-definition stx #'lambda)])
#`(define-syntax #,name
(let ([#,name #,def]) (trace #,name) #,name)))])))
(require 'trace-et-al 'chez-like)
(provide trace untrace
current-trace-print-results
current-trace-print-args
trace-call
current-trace-notify
current-prefix-out current-prefix-in
trace-define trace-let trace-lambda
trace-define-syntax)