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