suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Only style differences, no real code changes.

Browse Source 
Before I do any other changes.

(The only real change is that `oprintf' was removed from stacktrace:
it wasn't used.)

svn: r88
This commit is contained in:
Eli Barzilay 2005-06-12 06:14:17 +00:00
parent 23125fec81
commit f0c7a677f7
4 changed files with 754 additions and 736 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

168
collects/errortrace/doc.txt
View File

@ -4,9 +4,9 @@
_coverage_ ]
_Errortrace_ is a stack-trace-on-exceptions/profiler/coverage tool for
MzScheme. Errortrace is not a complete debugger, and a real debugger
in DrScheme is expected soon; meanwhile, using errortrace might be
better than nothing.
MzScheme. Errortrace is not a complete debugger, and a real debugger
in DrScheme is expected soon; meanwhile, using errortrace might be
better than nothing.
Quick instructions
------------------
@ -14,40 +14,39 @@ Quick instructions
0) Throw away .zo versions of your source
1) Prefix your program with
(require (lib "errortrace.ss" "errortrace"))
(require (lib "errortrace.ss" "errortrace"))
or start MzScheme with the -M flag:
mzscheme -M errortrace
mzscheme -M errortrace
2) When an exception occurs, the exception handler
prints something like a stack trace, most recent
contexts first
2) When an exception occurs, the exception handler prints something
like a stack trace, most recent contexts first
The errortrace module is odd; don't import it into another
module. Instead, the errortrace module is meant to be invoked from the
The errortrace module is odd; don't import it into another module.
Instead, the errortrace module is meant to be invoked from the
top-level, so that it can install an evaluation handler, exception
handler, etc.
To reuse parts of the code of errortrace, import
_errortrace-lib.ss_. It contains all of the names here but
does not set the compilation handler or the error display handler.
To reuse parts of the code of errortrace, import _errortrace-lib.ss_.
It contains all of the names here but does not set the compilation
handler or the error display handler.
Exception Information
---------------------
Invoking the errortrace.ss module sets the compilation handler to
instrument Scheme source code. It also sets the error display handler
instrument Scheme source code. It also sets the error display handler
to report source information for an exception, and it sets the
`use-compiled-file-paths' parameter to trigger the use of
errortrace-specific .zo files.
NOTE: errortrace has no effect on code loaded as compiled byte code
(i.e., from a .zo file) or native code (i.e., from a .dll or .so
file). But use the "--mode errortrace" flag to Setup PLT to create
.zo files with errortrace information.
NOTE: errortrace has no effect on code loaded as compiled byte code
(i.e., from a .zo file) or native code (i.e., from a .dll or .so
file). But use the "--mode errortrace" flag to Setup PLT to create
.zo files with errortrace information.
Errortrace's instrumentation can be explicitly disabled via the
`instrumenting-enabled' boolean parameter. Instrumentation is on by
default. The `instrumenting-enabled' parameter affects only the way
`instrumenting-enabled' boolean parameter. Instrumentation is on by
default. The `instrumenting-enabled' parameter affects only the way
that source code is compiled, not the way that exception information
is reported.
@ -59,7 +58,7 @@ is reported.
The instrumentation for storing exception information slows most
programs by a factor of 2 or 3.
Do not load errortrace before writing .zo files. Errortrace
Do not load errortrace before writing .zo files. Errortrace
instruments S-expressions with unprintable values; this works fine if
the instrumented S-expression is passed to the default eval handler,
but neither the S-expression nor its byte-code form can be marshalled
@ -67,14 +66,14 @@ to a string.
The `print-error-trace' procedure takes a port and exception and
prints the errortrace-collected debugging information contained in the
exception. It is used by the exception handler installed by
exception. It is used by the exception handler installed by
errortrace.
> (print-error-trace output-port exn) - prints the errortrace
information in `exn' to `output-port'.
The `error-context-display-depth' parameter controls how much context
errortrace's exception handler displays. The default value is 10000.
errortrace's exception handler displays. The default value is 10000.
> (error-context-display-depth) - returns the current context display
depth
@ -84,7 +83,7 @@ errortrace's exception handler displays. The default value is 10000.
Profiling
---------
Errortrace's profiling instrumentation is off by default. Enable
Errortrace's profiling instrumentation is off by default. Enable
profiling instrumentation with the `profiling-enabled' boolean
parameter (but setting `instrumentation-enabled' to #f also disables
profiling):
@ -114,7 +113,7 @@ Profiling records:
in turn, provide a source location file and position).
* optionally, information about the procedure call path (something
like the stack trace) for every call to the procedure. Path
like the stack trace) for every call to the procedure. Path
information is collected when the `profile-paths-enabled' boolean
parameter is #t; the default is #f, but setting the parameter to #t
immediately affects all procedure instrumented for profiling
@ -125,7 +124,7 @@ Profiling records:
> (profile-paths-enabled on?) - enables/disables collecting path
information for profiling
Profiling information is accumulated in a hash table. If a procedure
Profiling information is accumulated in a hash table. If a procedure
is redefined, new profiling information is accumulated for the new
version of the procedure, but the old information is also preserved.
@ -144,7 +143,7 @@ To retrieve all profiling information accumulated so far, call
* the syntax source of the procedure; and
* a list of call paths, recorded while `profile-paths-enabled' is
set to #t. Each call path is a list containing two-element lists;
set to #t. Each call path is a list containing two-element lists;
each two-element list contains the calling procedure's name or
source expression and the calling procedure's source file or #f.
@ -154,7 +153,7 @@ information instrumentation).
> (output-profile-results paths? sort-time?)
Gets the current profile results and displays them. It optionally
Gets the current profile results and displays them. It optionally
shows paths information (if it is recorded) and sorts by either time
or call counts.
@ -162,7 +161,7 @@ Coverage
--------
Errortrace can track expression execution that is useful for checking
test coverage (i.e., simple expression coverage). Enable coverage
test coverage (i.e., simple expression coverage). Enable coverage
checking with the `execute-counts-enabled' boolean parameter (but
setting `instrumentation-enabled' to #f also disables execute
counting):
@ -173,7 +172,7 @@ counting):
instrumentation
> (get-execute-counts) - returns a list of pairs, one for each
instrumented expression. The first element of the pair is a syntax
instrumented expression. The first element of the pair is a syntax
object (usually containing source location information) for the
original expression, and the second element of the pair is the
number of times that the expression has been evaluated.
@ -181,7 +180,7 @@ counting):
> (annotate-executed-file filename-path) - writes the named file to
the current output port, inserting an additional line between each
source line to reflect execution counts (as reported by
`get-execute-counts'). An expression underlined with "^" has been
`get-execute-counts'). An expression underlined with "^" has been
executed 0 times; an expression underlined with "." has been
executed 1 time; and an expression underlined with "," has been
executed multiple times.
@ -190,15 +189,15 @@ _Re-using errortrace handlers_
-----------------------------------
The _errortrace-lib.ss_ module exports all of the exports of
"errortrace.ss", plus a few more. It does not install any handlers.
"errortrace.ss", plus a few more. It does not install any handlers.
The addition exports are as follows:
> (errortrace-compile-handler stx immediate-eval?) - compiles `stx'
using the compilation handler that was active when the
"errortrace-lib.ss" module was executed, but first instruments the
code for errortrace information. The code is instrumented only if
the namespace is the same as when the module was executed. This
code for errortrace information. The code is instrumented only if
the namespace is the same as when the module was executed. This
procedure is suitable for use as a compilation handler.
> (errortrace-error-display-handler string exn) - displays information
@ -206,12 +205,12 @@ The addition exports are as follows:
display handler.
> (errortrace-annotate stx) - macro-expands and instruments the given
top-level form. If the form is a module named `errortrace-key', no
instrumentation is applied. This annotation function is used by
top-level form. If the form is a module named `errortrace-key', no
instrumentation is applied. This annotation function is used by
`errortrace-compile-handler'.
> (annotate-top stx) - like `errortrace-annotate', but without the
special case for `errortrace-key'. Also, if `stx' is a module
special case for `errortrace-key'. Also, if `stx' is a module
declaration, it is not enriched with imports to explicitly load
errortrace run-time support.
@ -219,8 +218,8 @@ The addition exports are as follows:
_Re-using errortrace stack tracing_
-----------------------------------
The errortrace collection also includes a _stacktrace.ss_ library.
It exports the _stacktrace@_ unit and it import signature
The errortrace collection also includes a _stacktrace.ss_ library. It
exports the _stacktrace@_ unit and it import signature
_stacktrace-imports^_, and its export signature _stacktrace^_.
The export signature contains these names:
@ -234,82 +233,79 @@ The export signature contains these names:
The first two functions annotate expressions with errortrace
information. The `annotate-top' function should be called with a
top-level expression, and `annotate' should be called with a nested
expression (e.g., by `profile-point'). The boolean argument indicates
expression (e.g., by `profile-point'). The boolean argument indicates
whether the expression is a transformer expression (#t) or a normal
expression (#f).
The `st-mark-source' and `st-mark-bindings' functions extract
information from a particular kind of value. The value must
be created by `make-st-mark'. `st-mark-source' extracts
the value originally provided to the expression-maker, and
`st-mark-bindings' returns local binding information (if available).
information from a particular kind of value. The value must be
created by `make-st-mark'. `st-mark-source' extracts the value
originally provided to the expression-maker, and `st-mark-bindings'
returns local binding information (if available).
The import signature contains these names:
> with-mark : syntax syntax -> syntax
This procedure is called by `annotate' and `annotate-top'
to wrap expressions with `with-continuation-mark'. The
first argument is the source expression and the second
argument is the expression to be wrapped.
This procedure is called by `annotate' and `annotate-top' to wrap
expressions with `with-continuation-mark'. The first argument is
the source expression and the second argument is the expression to
be wrapped.
> test-coverage-enabled : (parameter boolean)
This parameter determines if the test coverage annotation
is inserted into the code. This parameter controls how
compilation happens -- it does not affect the dynamic
behavior of the already compiled code. If the parameter is
set, calls to test-covered are inserted into the code (and
initialize-test-coverage-point is called during
compilation). If not, no calls to test-covered are inserted.
This parameter determines if the test coverage annotation is
inserted into the code. This parameter controls how compilation
happens -- it does not affect the dynamic behavior of the already
compiled code. If the parameter is set, calls to test-covered are
inserted into the code (and initialize-test-coverage-point is called
during compilation). If not, no calls to test-covered are inserted.
> test-covered : symbol -> void
During execution of the program, this is called for each
point with the key for that program point that was passed
to initialize-test-coverage-point.
During execution of the program, this is called for each point with
the key for that program point that was passed to
initialize-test-coverage-point.
> initialize-test-coverage-point : symbol syntax -> void
During compilation of the program, this function is called
with each sub-expression of the program. The first
argument is a special key used to identify this program
point. The second argument is the syntax of this program
point.
During compilation of the program, this function is called with each
sub-expression of the program. The first argument is a special key
used to identify this program point. The second argument is the
syntax of this program point.
> profile-key : symbol
only used for profiling paths
only used for profiling paths.
> profiling-enabled : -> boolean
determines if profiling information is currently collected
(affects the behavior of compiling the code -- does not
affect running code). If this always returns #f,
the other profiling functions are never called.
determines if profiling information is currently collected (affects
the behavior of compiling the code -- does not affect running code).
If this always returns #f, the other profiling functions are never
called.
> initialize-profile-point : symbol (union #f syntax[symbol]) syntax -> void
called as the program is compiled for each profiling point
that might be encountered during the program's
execution. The first argument is a key identifying this
code. The second argument is the inferred name at this
point and the final argument is the syntax of this expression.
called as the program is compiled for each profiling point that
might be encountered during the program's execution. The first
argument is a key identifying this code. The second argument is the
inferred name at this point and the final argument is the syntax of
this expression.
> register-profile-start : symbol -> (union #f number)
Called when some profiled code is about to be executed. If
the result is a number, it is expected to be the current
number of milliseconds. The symbol is a key that is unique
to this fragment of code -- it is the same symbol passed
to initialize-profile-point for this code fragment.
Called when some profiled code is about to be executed. If the
result is a number, it is expected to be the current number of
milliseconds. The symbol is a key that is unique to this fragment
of code -- it is the same symbol passed to initialize-profile-point
for this code fragment.
> register-profile-done : symbol (union #f number) -> void
This function is called when some profiled code is
finished executing. The
Note that register-profile-start and register-profile-done
can be called in a nested manner; in this case, the result
of register-profile-point should be #f.
This function is called when some profiled code is finished
executing.
Note that register-profile-start and register-profile-done can be
called in a nested manner; in this case, the result of
register-profile-point should be #f.

420
collects/errortrace/errortrace-lib.ss
View File

@ -4,105 +4,109 @@
(module errortrace-lib mzscheme
(require "stacktrace.ss"
"errortrace-key.ss"
(lib "list.ss")
"errortrace-key.ss"
(lib "list.ss")
(lib "unitsig.ss"))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Test coverage run-time support
(define test-coverage-enabled (make-parameter #f))
(define test-coverage-info (make-hash-table))
(define (initialize-test-coverage-point key expr)
(hash-table-put! test-coverage-info key (list #f expr)))
(define (test-covered key)
(let ([v (hash-table-get test-coverage-info key)])
(set-car! v #t)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Profiling run-time support
(define profile-thread #f)
(define profile-key (gensym))
(define profiling-enabled (make-parameter #f))
(define profiling-record-enabled (make-parameter #t))
(define profile-paths-enabled (make-parameter #f))
(define profile-info (make-hash-table))
(define (initialize-profile-point key name expr)
(hash-table-put! profile-info key (list (box #f) 0 0 (and name (syntax-e name)) expr null)))
(hash-table-put! profile-info key
(list (box #f) 0 0 (and name (syntax-e name)) expr null)))
(define (register-profile-start key)
(and (profiling-record-enabled)
(let ([v (hash-table-get profile-info key)])
(let ([b (car v)]
[v (cdr v)])
(set-car! v (add1 (car v)))
(when (profile-paths-enabled)
(let ([v (cdddr v)])
(set-car! v (cons (current-continuation-marks profile-key) (car v)))))
(if (unbox b)
#f
(begin
(set-box! b #t)
(current-process-milliseconds)))))))
(let ([v (hash-table-get profile-info key)])
(let ([b (car v)]
[v (cdr v)])
(set-car! v (add1 (car v)))
(when (profile-paths-enabled)
(let ([v (cdddr v)])
(set-car! v (cons (current-continuation-marks profile-key)
(car v)))))
(if (unbox b)
#f
(begin
(set-box! b #t)
(current-process-milliseconds)))))))
(define (register-profile-done key start)
(when start
(let ([v (hash-table-get profile-info key)])
(let ([b (car v)]
[v (cddr v)])
(set-box! b #f)
(let ([v (cddr (hash-table-get profile-info key))])
(set-car! v (+ (- (current-process-milliseconds) start) (car v))))))))
(let ([b (car v)]
[v (cddr v)])
(set-box! b #f)
(let ([v (cddr (hash-table-get profile-info key))])
(set-car! v (+ (- (current-process-milliseconds) start)
(car v))))))))
(define (get-profile-results)
(hash-table-map profile-info (lambda (key val)
(let ([count (cadr val)]
[time (caddr val)]
[name (cadddr val)]
[expr (cadddr (cdr val))]
[cmss (cadddr (cddr val))])
(list count time name expr
(map
(lambda (cms)
(map (lambda (k)
(let ([v (cdr (hash-table-get profile-info k))])
(list (caddr v) (cadddr v))))
cms))
cmss))))))
(hash-table-map profile-info
(lambda (key val)
(let ([count (cadr val)]
[time (caddr val)]
[name (cadddr val)]
[expr (cadddr (cdr val))]
[cmss (cadddr (cddr val))])
(list count time name expr
(map (lambda (cms)
(map (lambda (k)
(let ([v (cdr (hash-table-get profile-info k))])
(list (caddr v) (cadddr v))))
cms))
cmss))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Stacktrace instrumenter
(define dynamic-errortrace-key
(dynamic-require '(lib "errortrace-key-syntax.ss" "errortrace")
'errortrace-key-syntax))
(dynamic-require '(lib "errortrace-key-syntax.ss" "errortrace")
'errortrace-key-syntax))
;; with-mark : stx stx -> stx
(define (with-mark mark expr)
(with-syntax ([expr expr]
[loc (make-st-mark mark)]
[et-key dynamic-errortrace-key])
[loc (make-st-mark mark)]
[et-key dynamic-errortrace-key])
(execute-point
mark
(syntax
(with-continuation-mark
et-key
loc
expr)))))
(with-continuation-mark
et-key
loc
expr)))))
(define-values/invoke-unit/sig stacktrace^ stacktrace@ #f stacktrace-imports^)
(define-values/invoke-unit/sig
stacktrace^ stacktrace@ #f stacktrace-imports^)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Execute counts
(define execute-info (make-hash-table))
(define execute-counts-enabled (make-parameter #f))
(define (register-executed-once key)
@ -111,16 +115,16 @@
(define (execute-point mark expr)
(if (execute-counts-enabled)
(let ([key (gensym)])
(hash-table-put! execute-info key (cons mark 0))
(with-syntax ([key (datum->syntax-object #f key (quote-syntax here))]
[expr expr]
[register-executed-once register-executed-once]) ; <--- 3D !
(syntax
(begin
(register-executed-once 'key)
expr))))
expr))
(let ([key (gensym)])
(hash-table-put! execute-info key (cons mark 0))
(with-syntax ([key (datum->syntax-object #f key (quote-syntax here))]
[expr expr]
[register-executed-once register-executed-once]);<- 3D!
(syntax
(begin
(register-executed-once 'key)
expr))))
expr))
(define (get-execute-counts)
(hash-table-map execute-info (lambda (k v) v)))
@ -128,91 +132,96 @@
(define (annotate-executed-file name)
(let ([name (path->complete-path name (current-directory))])
(let ([here (filter (lambda (s)
(and (equal? name (syntax-source (car s)))
(syntax-position (car s))))
(get-execute-counts))])
(let ([sorted (quicksort here (lambda (a b)
(let ([ap (syntax-position (car a))]
[bp (syntax-position (car b))])
(or (< ap bp) ; earlier first
(and (= ap bp)
(let ([as (syntax-span (car a))]
[bs (syntax-span (car b))])
(or (> as bs) ; wider first at same pos
(and (= as bs)
; less called for same region last
(> (cdr a) (cdr b))))))))))]
[pic (make-string (file-size name) #\space)])
;; fill out picture:
(for-each (lambda (s)
(let ([pos (sub1 (syntax-position (car s)))]
[span (syntax-span (car s))]
[key (let ([c (cdr s)])
(cond
[(zero? c) #\^]
[(= c 1) #\.]
[else #\,]))])
(let loop ([p pos])
(unless (= p (+ pos span))
(string-set! pic p key)
(loop (add1 p))))))
sorted)
;; Write annotated file
(with-input-from-file name
(lambda ()
(let loop ()
(let ([pos (file-position (current-input-port))]
[line (read-line (current-input-port) 'any)])
(unless (eof-object? line)
(printf "~a~n" line)
(let ([w (string-length line)])
;; Blank out leading spaces in pic:
(let loop ([i 0])
(cond
[(and (< i w)
(char-whitespace? (string-ref line i)))
(string-set! pic (+ pos i) (string-ref line i))
(loop (add1 i))]))
(printf "~a~n" (substring pic pos (+ pos w))))
(loop))))))))))
(and (equal? name (syntax-source (car s)))
(syntax-position (car s))))
(get-execute-counts))])
(let ([sorted
(quicksort
here
(lambda (a b)
(let ([ap (syntax-position (car a))]
[bp (syntax-position (car b))])
(or (< ap bp) ; earlier first
(and (= ap bp)
(let ([as (syntax-span (car a))]
[bs (syntax-span (car b))])
(or (> as bs) ; wider first at same pos
(and (= as bs)
;; less called for same region last
(> (cdr a) (cdr b))))))))))]
[pic (make-string (file-size name) #\space)])
;; fill out picture:
(for-each (lambda (s)
(let ([pos (sub1 (syntax-position (car s)))]
[span (syntax-span (car s))]
[key (let ([c (cdr s)])
(cond
[(zero? c) #\^]
[(= c 1) #\.]
[else #\,]))])
(let loop ([p pos])
(unless (= p (+ pos span))
(string-set! pic p key)
(loop (add1 p))))))
sorted)
;; Write annotated file
(with-input-from-file name
(lambda ()
(let loop ()
(let ([pos (file-position (current-input-port))]
[line (read-line (current-input-port) 'any)])
(unless (eof-object? line)
(printf "~a~n" line)
(let ([w (string-length line)])
;; Blank out leading spaces in pic:
(let loop ([i 0])
(cond
[(and (< i w)
(char-whitespace? (string-ref line i)))
(string-set! pic (+ pos i) (string-ref line i))
(loop (add1 i))]))
(printf "~a~n" (substring pic pos (+ pos w))))
(loop))))))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Eval handler, exception handler
(define instrumenting-enabled (make-parameter #t))
(define error-context-display-depth (make-parameter 10000 (lambda (x) (and (integer? x) x))))
(define instrumenting-enabled
(make-parameter #t))
(define error-context-display-depth
(make-parameter 10000 (lambda (x) (and (integer? x) x))))
;; port exn -> void
;; effect: prints out the context surrounding the exception
(define (print-error-trace p x)
(let loop ([n (error-context-display-depth)]
[l (map st-mark-source
(continuation-mark-set->list (exn-continuation-marks x)
errortrace-key))])
(continuation-mark-set->list (exn-continuation-marks x)
errortrace-key))])
(cond
[(or (zero? n) (null? l)) (void)]
[(pair? l)
(let* ([stx (car l)]
[source (syntax-source stx)]
[file (cond
[(string? source) source]
[(path? source)
(path->string source)]
[(not source)
#f]
[else
(format "~a" source)])]
[line (syntax-line stx)]
[col (syntax-column stx)]
[pos (syntax-position stx)])
(fprintf p "~a~a: ~e~n"
(or file "[unknown source]")
(cond
[line (format ":~a:~a" line col)]
[pos (format "::~a" pos)]
[else ""])
(syntax-object->datum stx))
(loop (- n 1) (cdr l)))])))
(let* ([stx (car l)]
[source (syntax-source stx)]
[file (cond
[(string? source) source]
[(path? source)
(path->string source)]
[(not source)
#f]
[else
(format "~a" source)])]
[line (syntax-line stx)]
[col (syntax-column stx)]
[pos (syntax-position stx)])
(fprintf p "~a~a: ~e~n"
(or file "[unknown source]")
(cond
[line (format ":~a:~a" line col)]
[pos (format "::~a" pos)]
[else ""])
(syntax-object->datum stx))
(loop (- n 1) (cdr l)))])))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Profile printer
@ -222,26 +231,28 @@
(error-print-width 50)
(printf "Sorting profile data...~n")
(let* ([sel (if sort-time? cadr car)]
[counts (quicksort (filter (lambda (c) (positive? (car c))) (get-profile-results))
(lambda (a b) (< (sel a) (sel b))))]
[total 0])
[counts (quicksort (filter (lambda (c) (positive? (car c)))
(get-profile-results))
(lambda (a b) (< (sel a) (sel b))))]
[total 0])
(for-each
(lambda (c)
(set! total (+ total (sel c)))
(printf "====================================================================~n")
(printf "time = ~a : no. = ~a : ~e in ~s~n" (cadr c) (car c) (caddr c) (cadddr c))
;; print call paths
(when paths?
(for-each
(lambda (cms)
(unless (null? cms)
(printf " VIA ~e" (caar cms))
(for-each
(lambda (cm)
(printf " <- ~e" (car cm)))
(cdr cms))
(printf "~n")))
(cadddr (cdr c)))))
(set! total (+ total (sel c)))
(printf "=========================================================~n")
(printf "time = ~a : no. = ~a : ~e in ~s~n"
(cadr c) (car c) (caddr c) (cadddr c))
;; print call paths
(when paths?
(for-each
(lambda (cms)
(unless (null? cms)
(printf " VIA ~e" (caar cms))
(for-each
(lambda (cm)
(printf " <- ~e" (car cm)))
(cdr cms))
(printf "~n")))
(cadddr (cdr c)))))
counts)
(printf "Total samples: ~a~n" total)))
@ -250,44 +261,45 @@
(define errortrace-annotate
(lambda (top-e)
(define (normal e)
(let ([ex (expand-syntax e)])
(annotate-top ex #f)))
(let ([ex (expand-syntax e)])
(annotate-top ex #f)))
(syntax-case top-e (begin module)
[(module name . reste)
(if (eq? (syntax-e #'name) 'errortrace-key)
top-e
(let ([top-e (expand-syntax top-e)])
(syntax-case top-e (module #%plain-module-begin)
[(module name init-import (#%plain-module-begin body ...))
(normal
#`(module name init-import
(#%plain-module-begin
#,((make-syntax-introducer)
#'(require (lib "errortrace-key.ss" "errortrace")))
#,((make-syntax-introducer)
#'(require-for-syntax (lib "errortrace-key.ss" "errortrace")))
body ...)))])))]
[_else
(normal top-e)])))
[(module name . reste)
(if (eq? (syntax-e #'name) 'errortrace-key)
top-e
(let ([top-e (expand-syntax top-e)])
(syntax-case top-e (module #%plain-module-begin)
[(module name init-import (#%plain-module-begin body ...))
(normal
#`(module name init-import
(#%plain-module-begin
#,((make-syntax-introducer)
#'(require (lib "errortrace-key.ss" "errortrace")))
#,((make-syntax-introducer)
#'(require-for-syntax
(lib "errortrace-key.ss" "errortrace")))
body ...)))])))]
[_else
(normal top-e)])))
(define errortrace-compile-handler
(let ([orig (current-compile)]
[ns (current-namespace)])
(lambda (e immediate-eval?)
(orig
(if (and (instrumenting-enabled)
(eq? ns (current-namespace))
(not (compiled-expression? (if (syntax? e)
(syntax-e e)
e))))
(let ([e2 (errortrace-annotate
(if (syntax? e)
e
(namespace-syntax-introduce
(datum->syntax-object #f e))))])
e2)
e)
immediate-eval?))))
(orig
(if (and (instrumenting-enabled)
(eq? ns (current-namespace))
(not (compiled-expression? (if (syntax? e)
(syntax-e e)
e))))
(let ([e2 (errortrace-annotate
(if (syntax? e)
e
(namespace-syntax-introduce
(datum->syntax-object #f e))))])
e2)
e)
immediate-eval?))))
(define errortrace-error-display-handler
(let ([orig (error-display-handler)])
@ -299,25 +311,25 @@
(print-error-trace p exn)
(orig (get-output-string p) exn))
(orig msg exn)))))
(provide errortrace-compile-handler
errortrace-error-display-handler
errortrace-annotate
print-error-trace
error-context-display-depth
instrumenting-enabled
errortrace-annotate
profiling-enabled
profiling-record-enabled
profile-paths-enabled
get-profile-results
output-profile-results
print-error-trace
error-context-display-depth
instrumenting-enabled
profiling-enabled
profiling-record-enabled
profile-paths-enabled
get-profile-results
output-profile-results
execute-counts-enabled
get-execute-counts
annotate-executed-file
execute-counts-enabled
get-execute-counts
annotate-executed-file
annotate-top))

30
collects/errortrace/errortrace.ss
View File

@ -4,23 +4,23 @@
(module errortrace mzscheme
(require "errortrace-lib.ss")
(provide print-error-trace
error-context-display-depth
instrumenting-enabled
profiling-enabled
profiling-record-enabled
profile-paths-enabled
get-profile-results
output-profile-results
(provide print-error-trace
error-context-display-depth
instrumenting-enabled
profiling-enabled
profiling-record-enabled
profile-paths-enabled
get-profile-results
output-profile-results
execute-counts-enabled
get-execute-counts
annotate-executed-file)
execute-counts-enabled
get-execute-counts
annotate-executed-file)
(current-compile errortrace-compile-handler)
(error-display-handler errortrace-error-display-handler)
(use-compiled-file-paths (cons (build-path "compiled" "errortrace")
(use-compiled-file-paths))))
(use-compiled-file-paths))))

872
collects/errortrace/stacktrace.ss
View File

@ -1,47 +1,46 @@
(module stacktrace mzscheme
(require (lib "unitsig.ss")
(lib "kerncase.ss" "syntax")
(lib "stx.ss" "syntax"))
(provide stacktrace@ stacktrace^ stacktrace-imports^)
(define-signature stacktrace-imports^ (with-mark
test-coverage-enabled
test-covered
initialize-test-coverage-point
profile-key
profiling-enabled
initialize-profile-point
register-profile-start
register-profile-done))
(define-signature stacktrace^ (annotate-top
annotate
make-st-mark
st-mark-source
st-mark-bindings))
(define o (current-output-port))
(define (oprintf . args) (apply fprintf o args))
(define-signature stacktrace-imports^
(with-mark
test-coverage-enabled
test-covered
initialize-test-coverage-point
profile-key
profiling-enabled
initialize-profile-point
register-profile-start
register-profile-done))
(define-signature stacktrace^
(annotate-top
annotate
make-st-mark
st-mark-source
st-mark-bindings))
(define stacktrace@
(unit/sig stacktrace^
(import stacktrace-imports^)
(define (short-version v depth)
(cond
[(identifier? v) (syntax-e v)]
[(null? v) null]
[(vector? v) (if (zero? depth)
#(....)
(list->vector
(short-version (vector->list v) (sub1 depth))))]
[(box? v) (if (zero? depth)
#&(....)
(box (short-version (unbox v) (sub1 depth))))]
[(pair? v)
(cond
[(identifier? v) (syntax-e v)]
[(null? v) null]
[(vector? v) (if (zero? depth)
#(....)
(list->vector
(short-version (vector->list v) (sub1 depth))))]
[(box? v) (if (zero? depth)
#&(....)
(box (short-version (unbox v) (sub1 depth))))]
[(pair? v)
(cond
[(zero? depth) '(....)]
[(memq (syntax-e (car v)) '(#%datum #%app #%top))
@ -49,12 +48,13 @@
[else
(cons (short-version (car v) (sub1 depth))
(short-version (cdr v) (sub1 depth)))])]
[(syntax? v) (short-version (syntax-e v) depth)]
[else v]))
[(syntax? v) (short-version (syntax-e v) depth)]
[else v]))
(define (make-st-mark stx)
(unless (syntax? stx)
(error 'make-st-mark "expected syntax object as argument, got ~e" stx))
(error 'make-st-mark
"expected syntax object as argument, got ~e" stx))
#`(quote (#,(short-version stx 10)
#,(let ([s (let ([source (syntax-source stx)])
(cond
@ -62,18 +62,14 @@
[(path? source) (path->string source)]
[(not source) #f]
[else (format "~a" source)]))])
(and s
(string->symbol s)))
(and s (string->symbol s)))
#,(syntax-line stx)
#,(syntax-column stx)
#,(syntax-position stx)
#,(syntax-span stx))))
(define (st-mark-source src) (datum->syntax-object
#f
(car src)
(cdr src)
#f))
(define (st-mark-source src)
(datum->syntax-object #f (car src) (cdr src) #f))
(define (st-mark-bindings x) null)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@ -82,26 +78,26 @@
;; The next procedure is called by `annotate' and `annotate-top' to wrap
;; expressions with test suite coverage information. Returning the
;; first argument means no tests coverage information is collected.
;; test-coverage-point : syntax syntax -> syntax
;; sets a test coverage point for a single expression
(define (test-coverage-point body expr)
(if (test-coverage-enabled)
(let ([key (gensym 'test-coverage-point)])
(initialize-test-coverage-point key expr)
(with-syntax ([key (datum->syntax-object #f key (quote-syntax here))]
(with-syntax ([key (datum->syntax-object
#f key (quote-syntax here))]
[body body]
[test-covered test-covered])
(syntax
(begin
(test-covered 'key)
body))))
#'(begin (test-covered 'key) body)))
body))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Profiling instrumenter
;; profile-point : (syntax[list of exprs] symbol-or-#f syntax boolean -> syntax[list of exprs])
;; profile-point :
;; (syntax[list of exprs] symbol-or-#f syntax boolean
;; -> syntax[list of exprs])
;; This procedure is called by `annotate' and `annotate-top' to wrap
;; expressions with profile collecting information. Returning the
@ -112,415 +108,429 @@
;; a transformer expression and #f for a normal expression.
(define (profile-point bodies name expr trans?)
(let ([key (gensym 'profile-point)])
(initialize-profile-point key name expr)
(with-syntax ([key (datum->syntax-object #f key (quote-syntax here))]
[start (datum->syntax-object #f (gensym) (quote-syntax here))]
[profile-key (datum->syntax-object #f profile-key (quote-syntax here))]
[register-profile-start register-profile-start]
[register-profile-done register-profile-done])
(with-syntax ([rest
(insert-at-tail*
(syntax (register-profile-done 'key start))
bodies
trans?)])
(syntax
(let ([start (register-profile-start 'key)])
(with-continuation-mark 'profile-key 'key
(begin . rest))))))))
(let ([key (gensym 'profile-point)])
(initialize-profile-point key name expr)
(with-syntax ([key (datum->syntax-object #f key (quote-syntax here))]
[start (datum->syntax-object
#f (gensym) (quote-syntax here))]
[profile-key (datum->syntax-object
#f profile-key (quote-syntax here))]
[register-profile-start register-profile-start]
[register-profile-done register-profile-done])
(with-syntax ([rest
(insert-at-tail*
(syntax (register-profile-done 'key start))
bodies
trans?)])
(syntax
(let ([start (register-profile-start 'key)])
(with-continuation-mark 'profile-key 'key
(begin . rest))))))))
(define (insert-at-tail* e exprs trans?)
(let ([new
(rebuild exprs
(let loop ([exprs exprs])
(if (stx-null? (stx-cdr exprs))
(list (cons (stx-car exprs)
(insert-at-tail e (stx-car exprs) trans?)))
(loop (stx-cdr exprs)))))])
(if (syntax? exprs)
(certify exprs new)
new)))
(let ([new
(rebuild exprs
(let loop ([exprs exprs])
(if (stx-null? (stx-cdr exprs))
(list (cons (stx-car exprs)
(insert-at-tail
e (stx-car exprs) trans?)))
(loop (stx-cdr exprs)))))])
(if (syntax? exprs)
(certify exprs new)
new)))
(define (insert-at-tail se sexpr trans?)
(with-syntax ([expr sexpr]
[e se])
(kernel-syntax-case sexpr trans?
;; negligible time to eval
[id
(identifier? sexpr)
(syntax (begin e expr))]
[(quote _) (syntax (begin e expr))]
[(quote-syntax _) (syntax (begin e expr))]
[(#%datum . d) (syntax (begin e expr))]
[(#%top . d) (syntax (begin e expr))]
;; No tail effect, and we want to account for the time
[(lambda . _) (syntax (begin0 expr e))]
[(case-lambda . _) (syntax (begin0 expr e))]
[(set! . _) (syntax (begin0 expr e))]
;; negligible time to eval
[id
(identifier? sexpr)
(syntax (begin e expr))]
[(quote _) (syntax (begin e expr))]
[(quote-syntax _) (syntax (begin e expr))]
[(#%datum . d) (syntax (begin e expr))]
[(#%top . d) (syntax (begin e expr))]
;; No tail effect, and we want to account for the time
[(lambda . _) (syntax (begin0 expr e))]
[(case-lambda . _) (syntax (begin0 expr e))]
[(set! . _) (syntax (begin0 expr e))]
[(let-values bindings . body)
(insert-at-tail* se sexpr trans?)]
[(letrec-values bindings . body)
(insert-at-tail* se sexpr trans?)]
[(begin . _)
(insert-at-tail* se sexpr trans?)]
[(with-continuation-mark . _)
(insert-at-tail* se sexpr trans?)]
[(begin0 body ...)
(certify sexpr (syntax (begin0 body ... e)))]
[(if test then)
(certify
sexpr
(append-rebuild
(rebuild sexpr (list (cons #'then (insert-at-tail
se (syntax then) trans?))))
#'(begin e (void))))]
[(if test then else)
;; WARNING: e inserted twice!
(certify
sexpr
(rebuild
sexpr
(list
(cons #'then (insert-at-tail se (syntax then) trans?))
(cons #'else (insert-at-tail se (syntax else) trans?)))))]
[(#%app . rest)
(if (stx-null? (syntax rest))
;; null constant
(syntax (begin e expr))
;; application; exploit guaranteed left-to-right evaluation
(insert-at-tail* se sexpr trans?))]
[_else
(error 'errortrace
"unrecognized (non-top-level) expression form: ~e"
(syntax-object->datum sexpr))])))
[(let-values bindings . body)
(insert-at-tail* se sexpr trans?)]
[(letrec-values bindings . body)
(insert-at-tail* se sexpr trans?)]
[(begin . _)
(insert-at-tail* se sexpr trans?)]
[(with-continuation-mark . _)
(insert-at-tail* se sexpr trans?)]
[(begin0 body ...)
(certify sexpr (syntax (begin0 body ... e)))]
[(if test then)
(certify
sexpr
(append-rebuild
(rebuild sexpr (list (cons #'then (insert-at-tail se (syntax then) trans?))))
#'(begin e (void))))]
[(if test then else)
;; WARNING: e inserted twice!
(certify
sexpr
(rebuild sexpr (list
(cons #'then (insert-at-tail se (syntax then) trans?))
(cons #'else (insert-at-tail se (syntax else) trans?)))))]
[(#%app . rest)
(if (stx-null? (syntax rest))
;; null constant
(syntax (begin e expr))
;; application; exploit guaranteed left-to-right evaluation
(insert-at-tail* se sexpr trans?))]
[_else
(error 'errortrace
"unrecognized (non-top-level) expression form: ~e"
(syntax-object->datum sexpr))])))
(define (profile-annotate-lambda name expr clause bodys-stx trans?)
(let* ([bodys (stx->list bodys-stx)]
[bodyl (map (lambda (e) (annotate e trans?))
bodys)])
(rebuild clause
(if (profiling-enabled)
(let ([prof-expr (profile-point bodyl name expr trans?)])
;; Tell rebuild to replace first expressions with (void),
;; and replace the last expression with prof-expr:
(let loop ([bodys bodys])
(if (null? (cdr bodys))
(list (cons (car bodys) prof-expr))
(cons (cons (car bodys) #'(void))
(loop (cdr bodys))))))
;; Map 1-to-1:
(map cons bodys bodyl)))))
(let* ([bodys (stx->list bodys-stx)]
[bodyl (map (lambda (e) (annotate e trans?))
bodys)])
(rebuild clause
(if (profiling-enabled)
(let ([prof-expr
(profile-point bodyl name expr trans?)])
;; Tell rebuild to replace first expressions with
;; (void), and replace the last expression with
;; prof-expr:
(let loop ([bodys bodys])
(if (null? (cdr bodys))
(list (cons (car bodys) prof-expr))
(cons (cons (car bodys) #'(void))
(loop (cdr bodys))))))
;; Map 1-to-1:
(map cons bodys bodyl)))))
(define (keep-lambda-properties orig new)
(let ([p (syntax-property orig 'method-arity-error)]
[p2 (syntax-property orig 'inferred-name)])
[p2 (syntax-property orig 'inferred-name)])
(let ([new (if p
(syntax-property new 'method-arity-error p)
new)])
(if p2
(syntax-property new 'inferred-name p2)
new))))
(syntax-property new 'method-arity-error p)
new)])
(if p2
(syntax-property new 'inferred-name p2)
new))))
(define (annotate-let expr trans? varss-stx rhss-stx bodys-stx)
(let ([varss (syntax->list varss-stx)]
[rhss (syntax->list rhss-stx)]
[bodys (syntax->list bodys-stx)])
(let ([rhsl (map
(lambda (vars rhs)
(annotate-named
(syntax-case vars ()
[(id)
(syntax id)]
[_else #f])
rhs
trans?))
varss
rhss)]
[bodyl (map
(lambda (body)
(annotate body trans?))
bodys)])
(rebuild expr (append (map cons bodys bodyl)
(map cons rhss rhsl))))))
(let ([rhsl (map
(lambda (vars rhs)
(annotate-named
(syntax-case vars ()
[(id)
(syntax id)]
[_else #f])
rhs
trans?))
varss
rhss)]
[bodyl (map
(lambda (body)
(annotate body trans?))
bodys)])
(rebuild expr (append (map cons bodys bodyl)
(map cons rhss rhsl))))))
(define (annotate-seq expr bodys-stx annotate trans?)
(let* ([bodys (syntax->list bodys-stx)]
[bodyl (map (lambda (b)
(annotate b trans?))
bodys)])
(rebuild expr (map cons bodys bodyl))))
[bodyl (map (lambda (b)
(annotate b trans?))
bodys)])
(rebuild expr (map cons bodys bodyl))))
(define orig-inspector (current-inspector))
(define (certify orig new)
(syntax-recertify new orig orig-inspector #f))
(syntax-recertify new orig orig-inspector #f))
(define (rebuild expr replacements)
(let loop ([expr expr]
[same-k (lambda () expr)]
[diff-k (lambda (x) x)])
(let ([a (assq expr replacements)])
(if a
(diff-k (cdr a))
(cond
[(pair? expr) (loop (car expr)
(lambda ()
(loop (cdr expr)
same-k
(lambda (y)
(diff-k (cons (car expr) y)))))
(lambda (x)
(loop (cdr expr)
(lambda ()
(diff-k (cons x (cdr expr))))
(lambda (y)
(diff-k (cons x y))))))]
[(vector? expr)
(loop (vector->list expr)
same-k
(lambda (x) (diff-k (list->vector x))))]
[(box? expr) (loop (unbox expr)
same-k
(lambda (x)
(diff-k (box x))))]
[(syntax? expr) (if (identifier? expr)
(same-k)
(loop (syntax-e expr)
same-k
(lambda (x)
(diff-k
(datum->syntax-object
expr
x
expr)))))]
[else (same-k)])))))
(let loop ([expr expr]
[same-k (lambda () expr)]
[diff-k (lambda (x) x)])
(let ([a (assq expr replacements)])
(if a
(diff-k (cdr a))
(cond
[(pair? expr) (loop (car expr)
(lambda ()
(loop (cdr expr)
same-k
(lambda (y)
(diff-k (cons (car expr) y)))))
(lambda (x)
(loop (cdr expr)
(lambda ()
(diff-k (cons x (cdr expr))))
(lambda (y)
(diff-k (cons x y))))))]
[(vector? expr)
(loop (vector->list expr)
same-k
(lambda (x) (diff-k (list->vector x))))]
[(box? expr) (loop (unbox expr)
same-k
(lambda (x)
(diff-k (box x))))]
[(syntax? expr) (if (identifier? expr)
(same-k)
(loop (syntax-e expr)
same-k
(lambda (x)
(diff-k
(datum->syntax-object
expr
x
expr)))))]
[else (same-k)])))))
(define (append-rebuild expr end)
(cond
[(syntax? expr)
(datum->syntax-object expr (append-rebuild (syntax-e expr) end) expr)]
[(pair? expr)
(cons (car expr) (append-rebuild (cdr expr) end))]
[(null? expr)
(list end)]
[else
(error 'append-rebuild "shouldn't get here")]))
(cond
[(syntax? expr)
(datum->syntax-object expr
(append-rebuild (syntax-e expr) end)
expr)]
[(pair? expr)
(cons (car expr) (append-rebuild (cdr expr) end))]
[(null? expr)
(list end)]
[else
(error 'append-rebuild "shouldn't get here")]))
(define (one-name names-stx)
(let ([l (syntax->list names-stx)])
(and (pair? l)
(null? (cdr l))
(car l))))
(let ([l (syntax->list names-stx)])
(and (pair? l)
(null? (cdr l))
(car l))))
(define (make-annotate top? name)
(lambda (expr trans?)
(test-coverage-point
(kernel-syntax-case expr trans?
[_
(identifier? expr)
(let ([b ((if trans? identifier-binding identifier-transformer-binding) expr)])
(cond
[(eq? 'lexical b)
;; lexical variable - no error possile
expr]
[(and (pair? b) (eq? '#%kernel (car b)))
;; built-in - no error possible
expr]
[else
;; might be undefined/uninitialized
(with-mark expr expr)]))]
[(#%top . id)
;; might be undefined/uninitialized
(with-mark expr expr)]
[(#%datum . _)
;; no error possible
expr]
;; Can't put annotation on the outside
[(define-values names rhs)
top?
(let ([marked (with-mark expr
(annotate-named
(one-name #'names)
(syntax rhs)
trans?))])
(certify
expr
(rebuild expr (list (cons #'rhs marked)))))]
[(begin . exprs)
top?
(certify
expr
(annotate-seq expr
(syntax exprs)
annotate-top trans?))]
[(define-syntaxes (name ...) rhs)
top?
(let ([marked (with-mark expr
(annotate-named
(one-name #'(name ...))
(syntax rhs)
#t))])
(certify
expr
(rebuild expr (list (cons #'rhs marked)))))]
(test-coverage-point
(kernel-syntax-case expr trans?
[_
(identifier? expr)
(let ([b ((if trans?
identifier-binding
identifier-transformer-binding)
expr)])
(cond
[(eq? 'lexical b)
;; lexical variable - no error possile
expr]
[(and (pair? b) (eq? '#%kernel (car b)))
;; built-in - no error possible
expr]
[else
;; might be undefined/uninitialized
(with-mark expr expr)]))]
[(define-values-for-syntax (name ...) rhs)
top?
(let ([marked (with-mark expr
(annotate-named
(one-name (syntax (name ...)))
(syntax rhs)
#t))])
(certify
expr
(rebuild expr (list (cons #'rhs marked)))))]
;; Just wrap body expressions
[(module name init-import (#%plain-module-begin body ...))
top?
(let ([bodys (syntax->list (syntax (body ...)))])
(let ([bodyl (map (lambda (b)
(annotate-top b trans?))
bodys)])
(certify
expr
(rebuild expr (map cons bodys bodyl)))))]
;; No way to wrap
[(require i ...) expr]
[(require-for-syntax i ...) expr]
[(require-for-template i ...) expr]
;; No error possible (and no way to wrap)
[(provide i ...) expr]
;; No error possible
[(quote _)
expr]
[(quote-syntax _)
expr]
;; Wrap body, also a profile point
[(lambda args . body)
(certify
expr
(keep-lambda-properties
expr
(profile-annotate-lambda name expr expr (syntax body)
trans?)))]
[(case-lambda clause ...)
(with-syntax ([([args . body] ...)
(syntax (clause ...))])
(let* ([clauses (syntax->list (syntax (clause ...)))]
[clausel
(map
(lambda (body clause) (profile-annotate-lambda name expr clause body trans?))
(syntax->list (syntax (body ...)))
clauses)])
(certify
expr
(keep-lambda-properties
expr
(rebuild expr (map cons clauses clausel))))))]
;; Wrap RHSs and body
[(let-values ([vars rhs] ...) . body)
(with-mark expr
(certify
expr
(annotate-let expr trans?
(syntax (vars ...))
(syntax (rhs ...))
(syntax body))))]
[(letrec-values ([vars rhs] ...) . body)
(with-mark expr
(certify
expr
(annotate-let expr trans?
(syntax (vars ...))
(syntax (rhs ...))
(syntax body))))]
;; Wrap RHS
[(set! var rhs)
(let ([new-rhs (annotate-named
(syntax var)
(syntax rhs)
trans?)])
;; set! might fail on undefined variable, or too many values:
(with-mark expr
(certify
expr
(rebuild expr (list (cons #'rhs new-rhs))))))]
;; Wrap subexpressions only
[(begin . body)
(with-mark expr
(certify
expr
(annotate-seq expr (syntax body)
annotate trans?)))]
[(begin0 . body)
(with-mark expr
(certify
expr
(annotate-seq expr (syntax body)
annotate trans?)))]
[(if tst thn els)
(let ([w-tst (annotate (syntax tst) trans?)]
[w-thn (annotate (syntax thn) trans?)]
[w-els (annotate (syntax els) trans?)])
(with-mark expr
(certify
expr
(rebuild expr (list (cons #'tst w-tst)
(cons #'thn w-thn)
(cons #'els w-els))))))]
[(if tst thn)
(let ([w-tst (annotate (syntax tst) trans?)]
[w-thn (annotate (syntax thn) trans?)])
(with-mark expr
(certify
expr
(rebuild expr (list (cons #'tst w-tst)
(cons #'thn w-thn))))))]
[(with-continuation-mark . body)
(with-mark expr
(certify
expr
(annotate-seq expr (syntax body)
annotate trans?)))]
[(#%top . id)
;; might be undefined/uninitialized
(with-mark expr expr)]
[(#%datum . _)
;; no error possible
expr]
;; Wrap whole application, plus subexpressions
[(#%app . body)
(cond
[(stx-null? (syntax body))
;; It's a null:
expr]
[(syntax-case* expr (#%app void) (if trans? module-transformer-identifier=? module-identifier=?)
[(#%app void) #t]
[_else #f])
;; It's (void):
expr]
[else
(with-mark expr
(certify
expr
(annotate-seq expr (syntax body)
annotate trans?)))])]
;; Can't put annotation on the outside
[(define-values names rhs)
top?
(let ([marked (with-mark expr
(annotate-named
(one-name #'names)
(syntax rhs)
trans?))])
(certify
expr
(rebuild expr (list (cons #'rhs marked)))))]
[(begin . exprs)
top?
(certify
expr
(annotate-seq expr
(syntax exprs)
annotate-top trans?))]
[(define-syntaxes (name ...) rhs)
top?
(let ([marked (with-mark expr
(annotate-named
(one-name #'(name ...))
(syntax rhs)
#t))])
(certify
expr
(rebuild expr (list (cons #'rhs marked)))))]
[(define-values-for-syntax (name ...) rhs)
top?
(let ([marked (with-mark expr
(annotate-named
(one-name (syntax (name ...)))
(syntax rhs)
#t))])
(certify
expr
(rebuild expr (list (cons #'rhs marked)))))]
;; Just wrap body expressions
[(module name init-import (#%plain-module-begin body ...))
top?
(let ([bodys (syntax->list (syntax (body ...)))])
(let ([bodyl (map (lambda (b)
(annotate-top b trans?))
bodys)])
(certify
expr
(rebuild expr (map cons bodys bodyl)))))]
;; No way to wrap
[(require i ...) expr]
[(require-for-syntax i ...) expr]
[(require-for-template i ...) expr]
;; No error possible (and no way to wrap)
[(provide i ...) expr]
;; No error possible
[(quote _)
expr]
[(quote-syntax _)
expr]
;; Wrap body, also a profile point
[(lambda args . body)
(certify
expr
(keep-lambda-properties
expr
(profile-annotate-lambda name expr expr (syntax body)
trans?)))]
[(case-lambda clause ...)
(with-syntax ([([args . body] ...)
(syntax (clause ...))])
(let* ([clauses (syntax->list (syntax (clause ...)))]
[clausel (map
(lambda (body clause)
(profile-annotate-lambda
name expr clause body trans?))
(syntax->list (syntax (body ...)))
clauses)])
(certify
expr
(keep-lambda-properties
expr
(rebuild expr (map cons clauses clausel))))))]
;; Wrap RHSs and body
[(let-values ([vars rhs] ...) . body)
(with-mark expr
(certify
expr
(annotate-let expr trans?
(syntax (vars ...))
(syntax (rhs ...))
(syntax body))))]
[(letrec-values ([vars rhs] ...) . body)
(with-mark expr
(certify
expr
(annotate-let expr trans?
(syntax (vars ...))
(syntax (rhs ...))
(syntax body))))]
;; Wrap RHS
[(set! var rhs)
(let ([new-rhs (annotate-named
(syntax var)
(syntax rhs)
trans?)])
;; set! might fail on undefined variable, or too many values:
(with-mark expr
(certify
expr
(rebuild expr (list (cons #'rhs new-rhs))))))]
;; Wrap subexpressions only
[(begin . body)
(with-mark expr
(certify
expr
(annotate-seq expr #'body annotate trans?)))]
[(begin0 . body)
(with-mark expr
(certify
expr
(annotate-seq expr #'body annotate trans?)))]
[(if tst thn els)
(let ([w-tst (annotate (syntax tst) trans?)]
[w-thn (annotate (syntax thn) trans?)]
[w-els (annotate (syntax els) trans?)])
(with-mark expr
(certify
expr
(rebuild expr (list (cons #'tst w-tst)
(cons #'thn w-thn)
(cons #'els w-els))))))]
[(if tst thn)
(let ([w-tst (annotate (syntax tst) trans?)]
[w-thn (annotate (syntax thn) trans?)])
(with-mark expr
(certify
expr
(rebuild expr (list (cons #'tst w-tst)
(cons #'thn w-thn))))))]
[(with-continuation-mark . body)
(with-mark expr
(certify
expr
(annotate-seq expr (syntax body)
annotate trans?)))]
;; Wrap whole application, plus subexpressions
[(#%app . body)
(cond
[(stx-null? (syntax body))
;; It's a null:
expr]
[(syntax-case* expr (#%app void)
(if trans?
module-transformer-identifier=?
module-identifier=?)
[(#%app void) #t]
[_else #f])
;; It's (void):
expr]
[else
(with-mark expr (certify
expr
(annotate-seq expr (syntax body)
annotate trans?)))])]
[_else
(error 'errortrace "unrecognized expression form~a: ~e"
(if top? " at top-level" "")
(syntax-object->datum expr))])
expr)))
[_else
(error 'errortrace
"unrecognized expression form~a: ~e"
(if top? " at top-level" "")
(syntax-object->datum expr))])
expr)))
(define annotate (make-annotate #f #f))
(define annotate-top (make-annotate #t #f))
(define annotate-named (lambda (name expr trans?) ((make-annotate #t name) expr trans?))))))
(define (annotate-named name expr trans?)
((make-annotate #t name) expr trans?)))))