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

update trace. use > for new stack frames and < for return values. prefixes are parameterized

Browse Source 
svn: r16055

original commit: 1c129b829b2ceb8419c6e96f3aa1fd884c8cb362
This commit is contained in:
Jon Rafkind 2009-09-17 21:52:07 +00:00
parent de06e87271
commit 572f69c778
1 changed files with 271 additions and 289 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

560
collects/mzlib/trace.ss
View File

@ -1,311 +1,293 @@
#lang scheme/base
(module trace scheme/base (require scheme/pretty
(require scheme/pretty (for-syntax scheme/base))
(for-syntax scheme/base))
(provide trace untrace (provide trace untrace
current-trace-print-args trace-apply current-trace-print-args trace-apply
current-trace-notify) current-trace-notify
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-in (make-parameter ">"))
(define (as-spaces s) (define (as-spaces s)
(build-string (string-length s) (make-string (string-length s) #\space))
(lambda (i) #\space)))
(define-struct prefix-entry (for-first for-rest))
(define prefixes (make-vector 20 #f)) (define-struct prefix-entry (for-first for-rest))
(define prefix-vector-length 20)
(define lookup-prefix (define prefixes (make-hash))
(lambda (n)
(and (< n prefix-vector-length)
(vector-ref prefixes n))))
(define insert-prefix (define (lookup-prefix n label)
(lambda (n first rest) (hash-ref prefixes (cons n label) (lambda () #f)))
(if (>= n prefix-vector-length)
(let ((v (make-vector (* 2 prefix-vector-length) #f)))
(let loop ((k 0))
(when (< k prefix-vector-length)
(vector-set! v k (vector-ref prefixes k))
(loop (add1 k))))
(set! prefixes v)
(set! prefix-vector-length (* 2 prefix-vector-length))
(insert-prefix n first rest))
(vector-set! prefixes n (make-prefix-entry first rest)))))
(define construct-prefixes (define (insert-prefix n label first rest)
(lambda (level) (hash-set! prefixes (cons n label) (make-prefix-entry first rest)))
(let loop ((n level)
(first '("|"))
(rest '(" ")))
(if (>= n max-dash-space-depth)
(let-values (((pre-first pre-rest)
(build-prefixes number-nesting-depth)))
(let ((s (number->string level)))
(values
(apply string-append
(cons pre-first (cons "[" (cons s (cons "]" '())))))
(apply string-append
(cons pre-rest (cons " " (cons (as-spaces s)
(cons " " '()))))))))
(cond
((= n 0) (values (apply string-append (reverse first))
(apply string-append (reverse rest))))
((= n 1) (loop (- n 1)
(cons '" " first)
(cons '" " rest)))
(else (loop (- n 2)
(cons " |" first)
(cons " " rest))))))))
(define build-prefixes (define (construct-prefixes level label)
(lambda (level) (let loop ([n level]
(let ((p (lookup-prefix level))) [first (list label)]
(if p [rest '(" ")])
(values (prefix-entry-for-first p) (if (>= n max-dash-space-depth)
(prefix-entry-for-rest p)) (let-values ([(pre-first pre-rest)
(let-values (((first rest) (build-prefixes number-nesting-depth label)])
(construct-prefixes level))) (let ((s (number->string level)))
(insert-prefix level first rest) (values
(values first rest)))))) (string-append pre-first "[" s "] ")
(string-append pre-rest " " (as-spaces s) " "))))
(cond
[(= n 0) (values (apply string-append (reverse first))
(apply string-append (reverse rest)))]
[(= n 1) (loop (- n 1)
(cons '" " first)
(cons '" " rest))]
[else (loop (- n 2)
(cons (format " ~a" label) first)
(cons " " rest))]))))
(define current-trace-notify (define (build-prefixes level label)
(make-parameter (lambda (s) (let ([p (lookup-prefix level label)])
(display s) (if p
(newline)) (values (prefix-entry-for-first p)
(lambda (p) (prefix-entry-for-rest p))
(unless (and (procedure? p) (let-values (((first rest)
(procedure-arity-includes? p 1)) (construct-prefixes level label)))
(raise-type-error 'current-trace-notify (insert-prefix level label first rest)
"procedure (arity 1)" (values first rest)))))
p))
p)))
(define (as-trace-notify thunk) (define current-trace-notify
(let ([p (open-output-bytes)]) (make-parameter (lambda (s)
(parameterize ([current-output-port p]) (display s)
(thunk)) (newline))
(let ([b (get-output-bytes p #t 0 (lambda (p)
;; drop newline: (unless (and (procedure? p)
(sub1 (file-position p)))]) (procedure-arity-includes? p 1))
((current-trace-notify) (bytes->string/utf-8 b))))) (raise-type-error 'current-trace-notify
"procedure (arity 1)"
p))
p)))
(define -:trace-print-args (define (as-trace-notify thunk)
(lambda (name args kws kw-vals level) (let ([p (open-output-bytes)])
(as-trace-notify (parameterize ([current-output-port p])
(lambda () (thunk))
((current-trace-print-args) name args kws kw-vals level))))) (let ([b (get-output-bytes p #t 0
;; drop newline:
(sub1 (file-position p)))])
((current-trace-notify) (bytes->string/utf-8 b)))))
(define current-trace-print-args (define -:trace-print-args
(make-parameter (lambda (name args kws kw-vals level)
(lambda (name args kws kw-vals level) (as-trace-notify
(let-values (((first rest) (lambda ()
(build-prefixes level))) ((current-trace-print-args) name args kws kw-vals level)))))
(parameterize ((pretty-print-print-line
(lambda (n port offset width)
(display
(if n
(if (zero? n) first
(format "~n~a" rest))
(format "~n"))
port)
(if n
(if (zero? n)
(string-length first)
(string-length rest))
0))))
(pretty-print (append (cons name args)
(apply append (map list kws kw-vals)))))))))
(define -:trace-print-results
(lambda (name results level)
(as-trace-notify
(lambda ()
(trace-print-results name results level)))))
(define trace-print-results (define current-trace-print-args
(lambda (name results level) (make-parameter
(let-values (((first rest) (lambda (name args kws kw-vals level)
(build-prefixes level))) (let-values (((first rest)
(parameterize ((pretty-print-print-line (build-prefixes level (current-prefix-in))))
(lambda (n port offset width) (parameterize ((pretty-print-print-line
(display (lambda (n port offset width)
(if n (display
(if (zero? n) first (if n
(format "~n~a" rest)) (if (zero? n) first
(format "~n")) (format "~n~a" rest))
port) (format "~n"))
(if n port)
(if (zero? n) (if n
(string-length first) (if (zero? n)
(string-length rest)) (string-length first)
0)))) (string-length rest))
(cond 0))))
((null? results) (pretty-print (append (cons name args)
(pretty-display "*** no values ***")) (apply append (map list kws kw-vals)))))))))
((null? (cdr results))
(pretty-print (car results))) (define -:trace-print-results
(else (lambda (name results level)
(pretty-print (car results)) (as-trace-notify
(parameterize ((pretty-print-print-line (lambda ()
(lambda (n port offset width) (trace-print-results name results level)))))
(display
(if n (define trace-print-results
(if (zero? n) rest (lambda (name results level)
(format "~n~a" rest)) (let-values (((first rest)
(format "~n")) (build-prefixes level (current-prefix-out))))
port) (parameterize ((pretty-print-print-line
(if n (lambda (n port offset width)
(string-length rest) (display
0)))) (if n
(for-each pretty-print (cdr results))))))))) (if (zero? n) first
(format "~n~a" rest))
(format "~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))
(format "~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 null (current-inspector) 0)) (make-struct-type 'traced-proc #f 2 0 #f null (current-inspector) 0))
;; 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-apply id f kws kw-vals . args) (do-traced id args kws kw-vals f)) (define (trace-apply id f kws kw-vals . args) (do-traced id args kws kw-vals f))
;; Apply a traced procedure to arguments, printing arguments
;; and results. We set and inspect the -:trace-level-key continuation
;; mark a few times to detect tail calls.
(define (do-traced id args kws kw-vals real-value)
(let* ([levels (continuation-mark-set->list
(current-continuation-marks)
-:trace-level-key)]
[level (if (null? levels) 0 (car levels))])
;; Tentatively push the new depth level:
(with-continuation-mark
-:trace-level-key
(add1 level)
;; Check for tail-call => car of levels replaced,
;; which means that the first two new marks are
;; not consecutive:
(let ([new-levels (continuation-mark-set->list
(current-continuation-marks)
-:trace-level-key)])
(if (and (pair? (cdr new-levels))
(> (car new-levels) (add1 (cadr new-levels))))
;; Tail call: reset level and just call real-value.
;; (This is in tail position to the call to `do-traced'.)
;; We don't print the results, because the original
;; call will.
(begin
(-:trace-print-args id args kws kw-vals (sub1 level))
(with-continuation-mark
-:trace-level-key
(car levels)
(if (null? kws)
(apply real-value args)
(keyword-apply real-value kws kw-vals args))))
;; Not a tail call; push the old level, again, to ensure
;; that when we push the new level, we have consecutive
;; levels associated with the mark (i.e., set up for
;; tail-call detection the next time around):
(begin
(-:trace-print-args id args kws kw-vals level)
(with-continuation-mark
-:trace-level-key
level
(call-with-values (lambda ()
(with-continuation-mark
-:trace-level-key
(add1 level)
(if (null? kws)
(apply real-value args)
(keyword-apply real-value kws kw-vals args))))
(lambda results
(flush-output)
;; Print the results:
(-:trace-print-results id results level)
;; Return the results:
(apply values results))))))))))
(define-syntax trace ;; Apply a traced procedure to arguments, printing arguments
(lambda (stx) ;; and results. We set and inspect the -:trace-level-key continuation
(syntax-case stx () ;; mark a few times to detect tail calls.
[(_ id ...) (define (do-traced id args kws kw-vals real-value)
(let ([ids (syntax->list (syntax (id ...)))]) (let* ([levels (continuation-mark-set->list
(for-each (lambda (id) (current-continuation-marks)
(unless (identifier? id) -:trace-level-key)]
(raise-syntax-error [level (if (null? levels) 0 (car levels))])
#f ;; Tentatively push the new depth level:
"not an identifier" (with-continuation-mark
stx -:trace-level-key
id))) (add1 level)
ids) ;; Check for tail-call => car of levels replaced,
(with-syntax ([(traced-name ...) ;; which means that the first two new marks are
(map (lambda (id) ;; not consecutive:
(datum->syntax (let ([new-levels (continuation-mark-set->list
id (current-continuation-marks)
(string->symbol -:trace-level-key)])
(string-append "traced-" (if (and (pair? (cdr new-levels))
(symbol->string (syntax-e id)))) (> (car new-levels) (add1 (cadr new-levels))))
#f)) ;; Tail call: reset level and just call real-value.
ids)]) ;; (This is in tail position to the call to `do-traced'.)
#'(do-trace ;; We don't print the results, because the original
'(id ...) ;; call will.
(list id ...) (begin
(list (lambda (v) (set! id v)) ...) (-:trace-print-args id args kws kw-vals (sub1 level))
(list (with-continuation-mark
(let ([real-value id]) -:trace-level-key
(let ([traced-name (car levels)
(make-keyword-procedure (if (null? kws)
(lambda (kws vals . args) (apply real-value args)
(do-traced 'id args kws vals real-value)) (keyword-apply real-value kws kw-vals args))))
(lambda args ;; Not a tail call; push the old level, again, to ensure
(do-traced 'id args null null real-value)))]) ;; that when we push the new level, we have consecutive
traced-name)) ;; levels associated with the mark (i.e., set up for
...))))]))) ;; tail-call detection the next time around):
(begin
(-:trace-print-args id args kws kw-vals level)
(with-continuation-mark
-:trace-level-key
level
(call-with-values (lambda ()
(with-continuation-mark
-:trace-level-key
(add1 level)
(if (null? kws)
(apply real-value args)
(keyword-apply real-value kws kw-vals args))))
(lambda results
(flush-output)
;; Print the results:
(-:trace-print-results id results level)
;; Return the results:
(apply values results))))))))))
(define-syntax untrace (define-syntax trace
(lambda (stx) (lambda (stx)
(syntax-case stx () (syntax-case stx ()
[(_ id ...) [(_ id ...)
(let ([ids (syntax->list (syntax (id ...)))]) (let ([ids (syntax->list (syntax (id ...)))])
(for-each (lambda (id) (for-each (lambda (id)
(unless (identifier? id) (unless (identifier? id)
(raise-syntax-error (raise-syntax-error
#f #f
"not an identifier" "not an identifier"
stx stx
id))) id)))
ids) ids)
(syntax (with-syntax ([(traced-name ...)
(begin (map (lambda (id)
(when (traced-proc? id) (datum->syntax
(set! id (traced-proc-ref id 1))) id
...)))]))) (string->symbol
) (string-append "traced-"
(symbol->string (syntax-e id))))
#f))
ids)])
#'(do-trace
'(id ...)
(list id ...)
(list (lambda (v) (set! id v)) ...)
(list
(let ([real-value id])
(let ([traced-name
(make-keyword-procedure
(lambda (kws vals . args)
(do-traced 'id args kws vals real-value))
(lambda args
(do-traced 'id args null null real-value)))])
traced-name))
...))))])))
(define-syntax untrace
(lambda (stx)
(syntax-case stx ()
[(_ id ...)
(let ([ids (syntax->list (syntax (id ...)))])
(for-each (lambda (id)
(unless (identifier? id)
(raise-syntax-error
#f
"not an identifier"
stx
id)))
ids)
(syntax
(begin
(when (traced-proc? id)
(set! id (traced-proc-ref id 1)))
...)))])))