From 8decda38f94a92231e37e1766e885c83c4da05f2 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Tue, 2 Nov 2004 18:24:59 +0000 Subject: [PATCH] . original commit: d53614eb6e970ac347efd1d954a43f7c0896992e --- collects/mzlib/trace.ss | 147 +++++++++++++++++++++++++--------------- 1 file changed, 94 insertions(+), 53 deletions(-) diff --git a/collects/mzlib/trace.ss b/collects/mzlib/trace.ss index da6aa82..7e46d0c 100644 --- a/collects/mzlib/trace.ss +++ b/collects/mzlib/trace.ss @@ -1,11 +1,3 @@ -; Time-stamp: <97/08/19 15:07:32 shriram> -; Time-stamp: <97/07/12 12:44:01 shriram> - -; Differences from the Chez implementation: - -; - The code does not respect tail-calls. -; - If the library is loaded more than once, especially in the middle -; of a trace, the behavior is not well-defined. (module trace mzscheme (require "pretty.ss") @@ -82,12 +74,10 @@ (insert-prefix level first rest) (values first rest)))))) - (define -:trace-level (make-parameter -1)) - (define -:trace-print-args - (lambda (name args) + (lambda (name args level) (let-values (((first rest) - (build-prefixes (-:trace-level)))) + (build-prefixes level))) (parameterize ((pretty-print-print-line (lambda (n port offset width) (display @@ -104,9 +94,9 @@ (pretty-print (cons name args)))))) (define -:trace-print-results - (lambda (name results) + (lambda (name results level) (let-values (((first rest) - (build-prefixes (-:trace-level)))) + (build-prefixes level))) (parameterize ((pretty-print-print-line (lambda (n port offset width) (display @@ -149,6 +139,87 @@ (define -:trace-table (make-hash-table)) + ;; Install traced versions of a given set of procedures. The traced + ;; versions are also given, so that they can be constructed to have + ;; a nice name. + (define (do-trace ids mk-traced-procs) + (for-each (lambda (id) + (let ((global (namespace-variable-value + id #t + (lambda () (error 'trace "~s is not bound as a procedure" id))))) + (unless (procedure? global) + (error 'trace + "the top-level value of ~s is not a procedure" id)))) + ids) + (for-each (lambda (id mk-traced-proc) + (let ((global-value (namespace-variable-value id))) + (let ((table-entry (hash-table-get -:trace-table id (lambda () #f)))) + (unless (and table-entry + (eq? global-value + (-:traced-entry-trace-proc table-entry))) + (let* ([real-value global-value] + [traced-proc (mk-traced-proc real-value)]) + (hash-table-put! -:trace-table id + (-:make-traced-entry real-value traced-proc)) + (namespace-set-variable-value! id traced-proc #f)))))) + ids mk-traced-procs) + ids) + + ;; Key used for a continuation mark to indicate + ;; the nesting depth: + (define -:trace-level-key (gensym)) + + ;; 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 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 (sub1 level)) + (with-continuation-mark + -:trace-level-key + (car levels) + (apply real-value 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 level) + (with-continuation-mark + -:trace-level-key + level + (call-with-values (lambda () + (with-continuation-mark + -:trace-level-key + (add1 level) + (apply real-value args))) + (lambda results + (flush-output) + ;; Print the results: + (-:trace-print-results id results level) + ;; Return the results: + (apply values results)))))))))) + (define-syntax trace (lambda (stx) (syntax-case stx () @@ -171,45 +242,15 @@ (symbol->string (syntax-e id)))) #f)) ids)]) - (syntax - (begin - (let ((global (namespace-variable-value - 'id #t - (lambda () (error 'trace "~s is not bound as a procedure" 'id))))) - (unless (procedure? global) - (error 'trace - "the top-level value of ~s is not a procedure" 'id))) - ... - - (let ((global-value (namespace-variable-value 'id))) - (let ((table-entry (hash-table-get -:trace-table 'id (lambda () #f)))) - (unless (and table-entry - (eq? global-value - (-:traced-entry-trace-proc table-entry))) - (let* ((real-value global-value) - (traced-name - (lambda args - (dynamic-wind - (lambda () - (-:trace-level - (add1 (-:trace-level)))) - (lambda () - (-:trace-print-args 'id args) - (call-with-values - (lambda () - (apply real-value args)) - (lambda results - (flush-output) - (-:trace-print-results 'id results) - (apply values results)))) - (lambda () - (-:trace-level - (sub1 (-:trace-level)))))))) - (hash-table-put! -:trace-table 'id - (-:make-traced-entry real-value traced-name)) - (namespace-set-variable-value! 'id traced-name #f))))) - ... - '(id ...)))))]))) + #'(do-trace + '(id ...) + (list + (lambda (real-value) + (let ([traced-name + (lambda args + (do-traced 'id args real-value))]) + traced-name)) + ...))))]))) (define-syntax untrace (lambda (stx)