diff --git a/collects/errortrace/doc.txt b/collects/errortrace/doc.txt index bdba2c8df3..696dad3aae 100644 --- a/collects/errortrace/doc.txt +++ b/collects/errortrace/doc.txt @@ -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. diff --git a/collects/errortrace/errortrace-lib.ss b/collects/errortrace/errortrace-lib.ss index 76b99331cf..ee081bb829 100644 --- a/collects/errortrace/errortrace-lib.ss +++ b/collects/errortrace/errortrace-lib.ss @@ -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)) - + diff --git a/collects/errortrace/errortrace.ss b/collects/errortrace/errortrace.ss index ea23f8ff5f..646d91a563 100644 --- a/collects/errortrace/errortrace.ss +++ b/collects/errortrace/errortrace.ss @@ -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)))) diff --git a/collects/errortrace/stacktrace.ss b/collects/errortrace/stacktrace.ss index c962294db9..14ead1bea0 100644 --- a/collects/errortrace/stacktrace.ss +++ b/collects/errortrace/stacktrace.ss @@ -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?)))))