;;;; trace.scm (module trace (breakpoint trace untrace break unbreak trace-output-port continue c traced? trace-module untrace-module trace-verbose trace/untrace) (import scheme chicken csi) (use advice extras ports data-structures) (require-library srfi-1) (import (except srfi-1 break) miscmacros) (define *last-breakpoint* #f) (define *traced-procedures* '()) (define *broken-procedures* '()) (define *trace-indent-level* 0) (define trace-output-port (make-parameter (current-output-port))) (define trace-verbose (make-parameter #t)) (define (break-entry name args) ;; Does _not_ unwind! (##sys#call-with-current-continuation (lambda (c) (let ((exn (##sys#make-structure 'condition '(exn breakpoint) (list '(exn . message) "*** breakpoint ***" '(exn . arguments) (list (cons name args)) '(exn . location) name '(exn . continuation) c) ) ) ) (set! *last-breakpoint* exn) (signal exn) ) ) ) ) (define (break-resume exn) (let ((a (member '(exn . continuation) (##sys#slot exn 2)))) (if a ((cadr a) (void)) (error "condition has no continuation" exn) ) ) ) (define (breakpoint #!optional (name 'breakpoint)) (break-entry name '()) ) (define (trace-indent) (let ((port (trace-output-port))) (do ((i (fxmin 3 *trace-indent-level*) (fx- i 1))) ((fx<= i 0)) (write-char #\space port) ) (fprintf port "[~a] " *trace-indent-level*) ) ) (define (traced-procedure-entry name args) (let ((port (trace-output-port))) (trace-indent) (set! *trace-indent-level* (fx+ 1 *trace-indent-level*)) (write (cons name args) port) (write-char #\newline port) (flush-output port) ) ) (define (traced-procedure-exit name results) (let ((port (trace-output-port))) (set! *trace-indent-level* (fx- *trace-indent-level* 1)) (trace-indent) (fprintf port "~a -> " name) (if results (for-each (lambda (x) (write x port) (write-char #\space port) ) results) (display "(escaping)" port)) (write-char #\newline port) (flush-output port) ) ) (define (procedure-name proc) (cond ((procedure-information proc) => (lambda (info) (if (pair? info) (car info) info) ) ) (else ')) ) (define (do-trace procs) (for-each (lambda (s) (ensure procedure? s) (cond ((traced? s) (warning "procedure already traced" s) ) (else (let ((name (procedure-name s))) (when (trace-verbose) (fprintf (current-error-port) "; tracing ~a~%" name)) (set! *traced-procedures* (cons (cons s name) *traced-procedures*)) (advise 'around s (lambda (next args) (let ((results #f)) (dynamic-wind (cut traced-procedure-entry name args) (lambda () (call-with-values (cut apply next args) (lambda rs (set! results rs) (apply values rs)))) (cut traced-procedure-exit name results)))) '*trace*))))) procs) ) (define (do-untrace-all) (define (unadvise* p) (ignore-errors (unadvise p '*trace*))) (for-each (lambda (proc) (let ((proc (car proc))) (when (trace-verbose) (fprintf (current-error-port) "; untracing ~a~%" (procedure-name proc)) (unadvise* proc)))) *traced-procedures*) (set! *traced-procedures* '())) (define (do-untrace procs) (for-each (lambda (s) (ensure procedure? s) (let ((p (assq s *traced-procedures*)) (name (procedure-name s))) (cond ((not p) (warning "procedure not traced" name)) (else (when (trace-verbose) (fprintf (current-error-port) "; untracing ~a~%" name)) (ignore-errors (unadvise s '*trace*)) (set! *traced-procedures* (delete p *traced-procedures* eq?)))))) procs) ) (define (do-break procs) (for-each (lambda (s) (let ((name (procedure-name s))) (ensure procedure? s) (cond ((assq s *broken-procedures*) (warning "procedure already has break-point" name)) (else (when (trace-verbose) (fprintf (current-error-port) "; setting break-point in ~a~%" name)) (set! *broken-procedures* (cons (cons s name) *broken-procedures*)) (advise 'before s (lambda (args) (break-entry name args) ) '*break*) ) ))) procs) ) (define (do-unbreak procs) (for-each (lambda (s) (ensure procedure? s) (let ((p (assq s *broken-procedures*)) (name (procedure-name s))) (cond ((not p) (warning "procedure has no breakpoint" name)) (else (when (trace-verbose) (fprintf (current-error-port) "; removing break-point in ~a~%" name)) (ignore-errors (unadvise s '*break*)) (set! *broken-procedures* (delete p *broken-procedures* eq?) ) ) ) ) ) procs) ) (define (do-unbreak-all) (for-each (lambda (bp) (ignore-errors (unadvise (car bp) '*break*))) *broken-procedures*) (set! *broken-procedures* '()) (void)) (define (trace . procs) (cond ((null? procs) (when (pair? *traced-procedures*) (printf "Traced:~%~%") (for-each (lambda (p) (printf " ~a~%" (cdr p))) *traced-procedures*)) ) (else (do-trace procs) ) ) ) (define (untrace . procs) (cond ((null? procs) (do-untrace-all)) (else (do-untrace procs))) (void)) (define (break . procs) (cond ((null? procs) (when (pair? *broken-procedures*) (printf "Breakpoints:~%~%") (for-each (lambda (p) (printf " ~a~%" (cdr p))) *broken-procedures*)) ) (else (do-break procs) ) ) ) (define (unbreak . procs) (cond ((null? procs) (do-unbreak-all)) (else (do-unbreak procs)))) (define (continue #!optional (bp *last-breakpoint*)) (cond (*last-breakpoint* (let ((exn *last-breakpoint*)) (set! *last-breakpoint* #f) (break-resume exn) ) ) (else (display "no breakpoint pending\n") ) ) ) (define c continue) (define (traced? proc) (assq proc *traced-procedures*)) (define (trace/untrace . procs) (for-each (lambda (proc) ((if (traced? proc) do-untrace do-trace) (list proc))) procs)) (define (walk-module mname proc) (let* ((m (##sys#find-module mname)) (exps (nth-value 1 (##sys#module-exports m)))) (for-each (lambda (exp) (let* ((realname (cdr exp)) (prim (get realname '##core#primitive))) (if prim (warning "export is a core-library primitive - not traced" (car exp)) (when (##sys#symbol-has-toplevel-binding? realname) (let ((val (##sys#slot realname 0))) (proc val)))))) exps))) (define (trace-module . mnames) (for-each (lambda (mname) (walk-module mname trace)) mnames)) (define (untrace-module . mnames) (for-each (lambda (mname) (walk-module mname (lambda (proc) (when (traced? proc) (do-untrace (list proc)))))) mnames)) )