1;; Poor man's stack-trace-on-exceptions/profiler. 2;; See docs for information. 3 4(module calltrace-lib mzscheme 5 (require "stacktrace.rkt" 6 mzlib/list 7 mzlib/etc 8 mzlib/unit) 9 10 11 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 12 ;; Eval handler, exception handler 13 14 (define instrumenting-enabled (make-parameter #t)) 15 16 (define output-port (current-error-port)) 17 18 ;; (union symbol #f) syntax-object (list-of value) boolean int -> void 19 ;; effect: prints out the context surrounding the exception 20 (define (print-call-trace inferred-name original? src args improper? depth) 21 (build-list depth (lambda (n) (fprintf output-port " "))) 22 (fprintf output-port "~v\n" (cons (or inferred-name src) 23 (if improper? 24 (list->improper-list args) 25 args)))) 26 27 28 (define calltrace-eval-handler 29 (let ([orig (current-eval)] 30 [ns (current-namespace)]) 31 (lambda (e) 32 (if (and (eq? ns (current-namespace)) 33 (not (compiled-expression? (if (syntax? e) 34 (syntax-e e) 35 e)))) 36 ;; Loop to flatten top-level `begin's: 37 (let loop ([e (if (syntax? e) 38 e 39 (namespace-syntax-introduce 40 (datum->syntax-object #f e)))]) 41 (let ([top-e (expand-syntax-to-top-form e)]) 42 (syntax-case top-e (begin) 43 [(begin expr ...) 44 ;; Found a `begin', so expand/eval each contained 45 ;; expression one at a time 46 (foldl (lambda (e old-val) 47 (loop e)) 48 (void) 49 (syntax->list #'(expr ...)))] 50 [_else 51 ;; Not `begin', so proceed with normal expand and eval 52 (let* ([ex (expand-syntax top-e)] 53 [a (if (not (instrumenting-enabled)) 54 ex 55 (annotate ex))]) 56 (orig a))]))) 57 (orig e))))) 58 59 (define (list->improper-list a) 60 (cond [(null? a) (error 'list->improper-list "list->improper-list called with null argument: ~e" a)] 61 [(and (cons? a) (null? (cdr a))) (car a)] 62 [else (cons (car a) (list->improper-list (cdr a)))])) 63 64 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 65 ;; Stacktrace instrumenter 66 67 (define calltrace-key #`(quote #,(gensym 'key))) 68 69 (define-values/invoke-unit stacktrace@ 70 (import stacktrace-imports^) (export stacktrace^)) 71 72 (provide calltrace-eval-handler 73 instrumenting-enabled 74 annotate)) 75