78 lines
2.7 KiB
Racket
78 lines
2.7 KiB
Racket
|
|
;; Poor man's stack-trace-on-exceptions/profiler.
|
|
;; See docs for information.
|
|
|
|
(module calltrace-lib mzscheme
|
|
(require "stacktrace.ss"
|
|
mzlib/list
|
|
mzlib/etc
|
|
mzlib/unit)
|
|
|
|
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; Eval handler, exception handler
|
|
|
|
(define instrumenting-enabled (make-parameter #t))
|
|
|
|
(define output-port (current-error-port))
|
|
|
|
;; (union symbol #f) syntax-object (list-of value) boolean int -> void
|
|
;; effect: prints out the context surrounding the exception
|
|
(define (print-call-trace inferred-name original? src args improper? depth)
|
|
(build-list depth (lambda (n) (fprintf output-port " ")))
|
|
(fprintf output-port "~v\n" (cons (or inferred-name src)
|
|
(if improper?
|
|
(list->improper-list args)
|
|
args))))
|
|
|
|
|
|
(define calltrace-eval-handler
|
|
(let ([orig (current-eval)]
|
|
[ns (current-namespace)])
|
|
(lambda (e)
|
|
(if (and (eq? ns (current-namespace))
|
|
(not (compiled-expression? (if (syntax? e)
|
|
(syntax-e e)
|
|
e))))
|
|
;; Loop to flatten top-level `begin's:
|
|
(let loop ([e (if (syntax? e)
|
|
e
|
|
(namespace-syntax-introduce
|
|
(datum->syntax-object #f e)))])
|
|
(let ([top-e (expand-syntax-to-top-form e)])
|
|
(syntax-case top-e (begin)
|
|
[(begin expr ...)
|
|
;; Found a `begin', so expand/eval each contained
|
|
;; expression one at a time
|
|
(foldl (lambda (e old-val)
|
|
(loop e))
|
|
(void)
|
|
(syntax->list #'(expr ...)))]
|
|
[_else
|
|
;; Not `begin', so proceed with normal expand and eval
|
|
(let* ([ex (expand-syntax top-e)]
|
|
[a (if (not (instrumenting-enabled))
|
|
ex
|
|
(annotate ex))])
|
|
(orig a))])))
|
|
(orig e)))))
|
|
|
|
(define (list->improper-list a)
|
|
(cond [(null? a) (error 'list->improper-list "list->improper-list called with null argument: ~e" a)]
|
|
[(and (cons? a) (null? (cdr a))) (car a)]
|
|
[else (cons (car a) (list->improper-list (cdr a)))]))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; Stacktrace instrumenter
|
|
|
|
(define calltrace-key #`(quote #,(gensym 'key)))
|
|
|
|
(define-values/invoke-unit stacktrace@
|
|
(import stacktrace-imports^) (export stacktrace^))
|
|
|
|
(provide calltrace-eval-handler
|
|
instrumenting-enabled
|
|
annotate))
|
|
|