From 1e7eb34ba170b6aad77ee67c0f4b802950ff1a4b Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Sat, 26 Oct 2013 11:05:45 -0400 Subject: [PATCH] Implement statistical errortrace-based profiling. Add a mode to the profiler to use continuation marks inserted by the errortrace annotator instead of the runtime. Split `syntax/source-syntax` out from Typed Racket as a separate package, and use it to give better names for errortrace stack frames. Use caching to speed it up substantially when called repeatedly (as errortrace does). Also, document (internally) the format used by errortrace marks. --- .../errortrace/errortrace-lib.rkt | 10 ++- .../errortrace-lib/errortrace/stacktrace.rkt | 27 +++++- pkgs/errortrace-pkgs/errortrace-lib/info.rkt | 2 +- pkgs/plt-services/meta/props | 2 +- pkgs/profile-pkgs/profile-doc/info.rkt | 2 + .../profile/scribblings/sampler.scrbl | 10 ++- .../profile/scribblings/toplevel.scrbl | 12 ++- pkgs/profile-pkgs/profile-lib/info.rkt | 2 +- pkgs/profile-pkgs/profile-lib/main.rkt | 6 +- pkgs/profile-pkgs/profile-lib/sampler.rkt | 31 ++++++- pkgs/typed-racket-pkgs/source-syntax/info.rkt | 9 ++ .../source-syntax/source-syntax.rkt | 87 +++++++++++++++++++ .../typed-racket-lib/info.rkt | 1 + .../typed-racket/utils/syntax-traversal.rkt | 64 -------------- .../typed-racket/utils/tc-utils.rkt | 25 +++--- 15 files changed, 197 insertions(+), 93 deletions(-) create mode 100644 pkgs/typed-racket-pkgs/source-syntax/info.rkt create mode 100644 pkgs/typed-racket-pkgs/source-syntax/source-syntax.rkt delete mode 100644 pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/utils/syntax-traversal.rkt diff --git a/pkgs/errortrace-pkgs/errortrace-lib/errortrace/errortrace-lib.rkt b/pkgs/errortrace-pkgs/errortrace-lib/errortrace/errortrace-lib.rkt index 44863a08ca..78c826d25e 100644 --- a/pkgs/errortrace-pkgs/errortrace-lib/errortrace/errortrace-lib.rkt +++ b/pkgs/errortrace-pkgs/errortrace-lib/errortrace/errortrace-lib.rkt @@ -433,8 +433,10 @@ (define errortrace-annotate (lambda (top-e) (define (normal e) - (annotate-top (expand-syntax e) - (namespace-base-phase))) + (define expanded-e (expand-syntax e)) + (parameterize ([original-stx e] + [expanded-stx expanded-e]) + (annotate-top expanded-e (namespace-base-phase)))) (syntax-case top-e () [(mod name . reste) (and (identifier? #'mod) @@ -443,11 +445,11 @@ (namespace-base-phase))) (if (eq? (syntax-e #'name) 'errortrace-key) top-e - (let ([top-e (normal top-e)]) + (let ([expanded-e (normal top-e)]) (initialize-test-coverage) (add-test-coverage-init-code (transform-all-modules - top-e + expanded-e (lambda (top-e mod-id) (syntax-case top-e () [(mod name init-import mb) diff --git a/pkgs/errortrace-pkgs/errortrace-lib/errortrace/stacktrace.rkt b/pkgs/errortrace-pkgs/errortrace-lib/errortrace/stacktrace.rkt index 063c11a147..a85d9d2234 100644 --- a/pkgs/errortrace-pkgs/errortrace-lib/errortrace/stacktrace.rkt +++ b/pkgs/errortrace-pkgs/errortrace-lib/errortrace/stacktrace.rkt @@ -2,10 +2,14 @@ (require racket/unit syntax/kerncase syntax/stx + syntax/source-syntax (for-template racket/base) (for-syntax racket/base)) ; for matching -(provide stacktrace@ stacktrace^ stacktrace-imports^) +(define original-stx (make-parameter #f)) +(define expanded-stx (make-parameter #f)) + +(provide stacktrace@ stacktrace^ stacktrace-imports^ original-stx expanded-stx) (define-signature stacktrace-imports^ (with-mark @@ -19,6 +23,15 @@ register-profile-start register-profile-done)) +;; The intentionally-undocumented format of bindings introduced by `make-st-mark` is: +;; (cons syntax? (cons syntax? srcloc-list)) + +;; The first syntax object is the original annotated source expression as a (shrunken) +;; datum. + +;; The second syntax object is some part of the original syntax as a (shrunken) +;; datum, which contains the code that expanded to the annotated expression. + (define-signature stacktrace^ (annotate-top annotate @@ -55,14 +68,24 @@ [(syntax? v) (short-version (syntax-e v) depth)] [else v])) + (define recover-table (make-hash)) + (define (make-st-mark stx phase) (unless (syntax? stx) (error 'make-st-mark "expected syntax object as argument, got ~e" stx)) (cond [(syntax-source stx) + ;; this horrible indirection is needed because the errortrace + ;; unit is invoked only once but annotate-top might be called + ;; many times with diferent values for original-stx and + ;; expanded-stx + (define recover (hash-ref! recover-table (cons (original-stx) (expanded-stx)) + (lambda () + (recover-source-syntax (original-stx) (expanded-stx))))) + (define better-stx (and stx (recover stx))) (with-syntax ([quote (syntax-shift-phase-level #'quote phase)]) - #`(quote (#,(short-version stx 10) + #`(quote (#,(short-version better-stx 10) #,(syntax-source stx) #,(syntax-line stx) #,(syntax-column stx) diff --git a/pkgs/errortrace-pkgs/errortrace-lib/info.rkt b/pkgs/errortrace-pkgs/errortrace-lib/info.rkt index 877f35b89b..65f412fe32 100644 --- a/pkgs/errortrace-pkgs/errortrace-lib/info.rkt +++ b/pkgs/errortrace-pkgs/errortrace-lib/info.rkt @@ -1,6 +1,6 @@ #lang info (define collection 'multi) -(define deps '("base")) +(define deps '("base" "source-syntax")) (define pkg-desc "implementation (no documentation) part of \"errortrace\"") diff --git a/pkgs/plt-services/meta/props b/pkgs/plt-services/meta/props index 816675ee86..f08355833d 100755 --- a/pkgs/plt-services/meta/props +++ b/pkgs/plt-services/meta/props @@ -1058,7 +1058,7 @@ path/s is either such a string or a list of them. "pkgs/plt-services/meta/props" responsible (eli jay) drdr:command-line (racket "-um" * "verify") "pkgs/plt-services/meta/web" drdr:command-line #f "pkgs/preprocessor" responsible (eli) -"pkgs/profile-pkgs" responsible (eli) +"pkgs/profile-pkgs" responsible (eli samth stamourv) "pkgs/profile-pkgs/profile-lib/profile/analyzer.rkt" drdr:command-line (raco "test" *) "pkgs/r5rs-pkgs" responsible (mflatt) "pkgs/r6rs-pkgs" responsible (mflatt) diff --git a/pkgs/profile-pkgs/profile-doc/info.rkt b/pkgs/profile-pkgs/profile-doc/info.rkt index 0e2c38b2a5..0ecfc386ec 100644 --- a/pkgs/profile-pkgs/profile-doc/info.rkt +++ b/pkgs/profile-pkgs/profile-doc/info.rkt @@ -5,6 +5,8 @@ (define build-deps '("base" "scribble-lib" "profile-lib" + "errortrace-doc" + "errortrace-lib" "racket-doc")) (define pkg-desc "documentation part of \"profile\"") diff --git a/pkgs/profile-pkgs/profile-doc/profile/scribblings/sampler.scrbl b/pkgs/profile-pkgs/profile-doc/profile/scribblings/sampler.scrbl index f50f95df13..b39950c0ba 100644 --- a/pkgs/profile-pkgs/profile-doc/profile/scribblings/sampler.scrbl +++ b/pkgs/profile-pkgs/profile-doc/profile/scribblings/sampler.scrbl @@ -1,7 +1,8 @@ #lang scribble/doc @(require scribble/manual - (for-label racket/base racket/contract profile/sampler profile/analyzer)) + (for-label racket/base racket/contract profile/sampler profile/analyzer + errortrace/errortrace-key)) @title[#:tag "sampler"]{Collecting Profile Information} @@ -11,7 +12,8 @@ (listof (or/c thread? custodian?)))] [delay (>=/c 0.0)] [super-cust custodian? (current-custodian)] - [custom-keys (listof any/c) '()]) + [custom-keys (listof any/c) '()] + [#:use-errortrace? use-errortrace? any/c #f]) ((symbol?) (any/c) . ->* . any/c)]{ Creates a stack-snapshot collector thread, which tracks the given @@ -26,6 +28,10 @@ When @racket[custom-keys] are provided, the sampler takes snapshots of the continuation marks corresponding to the given keys, in addition to taking snapshots of the stack. +When @racket[use-errortrace?] is not @racket[#f], the @racket[errortrace-key] is +used to sample snapshots instead of the implicit key used by +@racket[continuation-mark-set->context]. + The resulting value is a controller function, which consumes a message consisting of a symbol and an optional argument, and can affect the sampler. The following messages are currently supported: diff --git a/pkgs/profile-pkgs/profile-doc/profile/scribblings/toplevel.scrbl b/pkgs/profile-pkgs/profile-doc/profile/scribblings/toplevel.scrbl index d4dcc3d572..3f204f08e3 100644 --- a/pkgs/profile-pkgs/profile-doc/profile/scribblings/toplevel.scrbl +++ b/pkgs/profile-pkgs/profile-doc/profile/scribblings/toplevel.scrbl @@ -2,6 +2,7 @@ @(require scribble/manual (for-label racket/base racket/contract profile profile/sampler + errortrace/errortrace-lib (only-in profile/analyzer analyze-samples profile?) (prefix-in text: profile/render-text))) @@ -23,7 +24,8 @@ intended as a convenient tool for profiling code. [#:periodic-renderer periodic-renderer (or/c #f (list/c (>=/c 0.0) (profile? . -> . any/c))) - #f]) + #f] + [#:use-errortrace? use-errortrace? any/c #f]) void?]{ Executes the given @racket[thunk] and collect profiling data during @@ -39,6 +41,14 @@ can customize the profiling: be close, but not identical to, the frequency in which data is actually sampled. (The @racket[delay] value is passed on to @racket[create-sampler], which creates the sampler thread.)} + +@item{When @racket[use-errortrace?] is not @racket[#f], more accurate + stack snapshots are captured using + @other-doc['(lib "errortrace/scribblings/errortrace.scrbl")]. Note that + when this is provided, it will only profile uncompiled files and files + compiled while using @racket[errortrace-compile-handler], and the profiled program + must be run using @commandline{racket -l errortrace -t program.rkt} + Removing compiled files (with extension @tt{.zo}) is sufficient to enable this.} @item{Due to the statistical nature of the profiler, longer executions result in more accurate analysis. You can specify a number of diff --git a/pkgs/profile-pkgs/profile-lib/info.rkt b/pkgs/profile-pkgs/profile-lib/info.rkt index 7b91a59739..9cb70b8b80 100644 --- a/pkgs/profile-pkgs/profile-lib/info.rkt +++ b/pkgs/profile-pkgs/profile-lib/info.rkt @@ -1,7 +1,7 @@ #lang info (define collection "profile") -(define deps '("base")) +(define deps '("base" "errortrace-lib")) (define build-deps '("at-exp-lib" "rackunit-lib")) diff --git a/pkgs/profile-pkgs/profile-lib/main.rkt b/pkgs/profile-pkgs/profile-lib/main.rkt index 3a14dbe91e..a6bb5f932c 100644 --- a/pkgs/profile-pkgs/profile-lib/main.rkt +++ b/pkgs/profile-pkgs/profile-lib/main.rkt @@ -11,12 +11,14 @@ #:repeat [rpt 1] #:threads [threads? #f] #:render [renderer text:render] - #:periodic-renderer [periodic-renderer #f]) + #:periodic-renderer [periodic-renderer #f] + #:use-errortrace? [et? #f]) (define cust (and threads? (make-custodian (current-custodian)))) (define sampler (create-sampler (if threads? (list cust (current-thread)) (current-thread)) - delay)) + delay + #:use-errortrace? et?)) (define periodic-thread (and periodic-renderer (let ([delay (car periodic-renderer)] diff --git a/pkgs/profile-pkgs/profile-lib/sampler.rkt b/pkgs/profile-pkgs/profile-lib/sampler.rkt index f29b0e9faf..ddd44b0f06 100644 --- a/pkgs/profile-pkgs/profile-lib/sampler.rkt +++ b/pkgs/profile-pkgs/profile-lib/sampler.rkt @@ -6,8 +6,24 @@ (provide create-sampler) +(require errortrace/errortrace-key) + +;; (cons sexp srcloc) -> (cons symbol srcloc) +;; just take the first symbol we find +(define (errortrace-preprocess frame) + (cons (and (car frame) + (let loop ([e (car frame)]) + (cond [(symbol? e) e] + [(pair? e) (loop (car e))] + [else (error 'errortrace-preprocess + "unexpected frame: ~a" frame)]))) + (and (cdr frame) + (apply srcloc (cdr frame))))) + ;; create-sampler : creates a sample collector thread, which tracks the given ;; `to-track' value every `delay' seconds. +;; Uses errortrace annotations when #:use-errortrace? is specified, otherwise +;; uses the native stack traces provided by `cms->context`. ;; * The input value can be either a thread (track just that thread), a ;; custodian (track all threads managed by the custodian), or a list of ;; threads and/or custodians. If a custodian is given, it must be @@ -57,7 +73,8 @@ ;; same format as the output of continuation-mark-set->list*. (define (create-sampler to-track delay [super-cust (current-custodian)] - [custom-keys #f]) + [custom-keys #f] + #:use-errortrace? [do-errortrace #f]) ;; the collected data (define snapshots '()) ;; listof (cons continuation-mark-key value/#f) @@ -116,9 +133,15 @@ (set! snapshots (cons (list* (thread-id t) (current-process-milliseconds t) - (map intern-entry - (continuation-mark-set->context - (continuation-marks t)))) + (if do-errortrace + (for/list ([frame (in-list + (continuation-mark-set->list + (continuation-marks t) + errortrace-key))]) + (intern-entry (errortrace-preprocess frame))) + (map intern-entry + (continuation-mark-set->context + (continuation-marks t))))) snapshots)))] [(custodian? t) (for-each loop (custodian-managed-list t super-cust))] diff --git a/pkgs/typed-racket-pkgs/source-syntax/info.rkt b/pkgs/typed-racket-pkgs/source-syntax/info.rkt new file mode 100644 index 0000000000..a0eebe8d7e --- /dev/null +++ b/pkgs/typed-racket-pkgs/source-syntax/info.rkt @@ -0,0 +1,9 @@ +#lang info + +(define collection "syntax") + +(define deps '("base")) + +(define pkg-desc "find mappings from expanded to source syntax") + +(define pkg-authors '(samth stamourv eli)) diff --git a/pkgs/typed-racket-pkgs/source-syntax/source-syntax.rkt b/pkgs/typed-racket-pkgs/source-syntax/source-syntax.rkt new file mode 100644 index 0000000000..199b4a9409 --- /dev/null +++ b/pkgs/typed-racket-pkgs/source-syntax/source-syntax.rkt @@ -0,0 +1,87 @@ +#lang racket/base + +;; from Eli + +(provide recover-source-syntax) + +;; -------------------- utilities + +(define (syntax-loc stx) (list (syntax-source stx) (syntax-position stx) (syntax-span stx))) + + +;; -------------------- the real stuff + + + +;; Look for `lookfor' in `enclosing', return chain of syntaxes from +;; the innermost out of only syntaxes with the given src, returns #f +;; if it can't find it. +(define (enclosing-syntaxes-with-source enclosing lookfor src) + (let loop ([r '()] [stx enclosing]) + ;(printf "stx is ~a\n" (syntax->datum stx)) + ;(printf "source is ~a\n" (syntax-source stx)) + (let* ([r* (if (and (syntax? stx) (eq? src (syntax-source stx))) + (cons stx r) + r)]) + (if (eq? stx lookfor) + r* + (let ([stx (if (syntax? stx) (syntax-e stx) stx)]) + (and (pair? stx) + (or (loop r* (car stx)) (loop r* (cdr stx))))))))) + + + + +;; Look for (the outermost) syntax in `orig' that has the same +;; location as `lookfor' which is coming from the expanded `orig', +;; given in `expanded'. +(define (recover-source-syntax orig expanded) + (define src (syntax-source orig)) + + ;; this maps source locations that are from orig to their syntax + (define syntax-locs (make-hash)) + + ;; build `syntax-locs` + (let loop ([stx orig]) + (when (syntax? stx) (hash-set! syntax-locs (syntax-loc stx) stx)) + (let ([stx (if (syntax? stx) (syntax-e stx) stx)]) + (when (pair? stx) (loop (car stx)) (loop (cdr stx))))) + + ;; this maps syntax from expanded to the original + (define parent-table (make-hasheq)) + + ;; if `expanded` is mapped to something, then we'll start with it + (define initial-target + (hash-ref syntax-locs (syntax-loc expanded) #f)) + + ;; this searches for lookfor in orig, building up the table as we go + (define (add-to-table lookfor) + (let loop ([stx expanded] [target initial-target]) + (cond + [(syntax? stx) + (define new-target + ;; check if `stx` has the same srcloc as something in orig + ;; in which case it's a good target to use + ;; otherwise keep using the old target + (hash-ref syntax-locs (syntax-loc stx) target)) + ;; map `stx` to the best enclosing syntax we have, if it's not already there + (hash-ref! parent-table stx new-target) + (cond + ;; if we got what we came for, stop + [(eq? stx lookfor) new-target] + + ;; take apart stx and loop on the components + [else + (define stxe (syntax-e stx)) + (and (pair? stxe) + (or (loop (car stxe) stx) (loop (cdr stxe) stx)))])] + [else #f]))) + + (lambda (lookfor) + (or + ;; we just might get a lookfor that is already in the original + (and (eq? src (syntax-source lookfor)) + (hash-ref syntax-locs (syntax-loc lookfor) #f)) + (hash-ref parent-table lookfor (λ () + (add-to-table lookfor) + (hash-ref parent-table lookfor #f)))))) diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/info.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/info.rkt index 5dbe4aab4d..524f6c0f7a 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-lib/info.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-lib/info.rkt @@ -8,6 +8,7 @@ "pconvert-lib" "unstable-contract-lib" "unstable-list-lib" + "source-syntax" "compatibility-lib" ;; to assign types "string-constants-lib")) diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/utils/syntax-traversal.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/utils/syntax-traversal.rkt deleted file mode 100644 index 41c7354039..0000000000 --- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/utils/syntax-traversal.rkt +++ /dev/null @@ -1,64 +0,0 @@ -#lang racket/base - -;; from Eli - -(provide look-for-in-orig) - -;; -------------------- utilities - -(define (syntax-loc stx) (list (syntax-source stx) (syntax-position stx) (syntax-span stx))) - -;; -------------------- the real stuff - -;; Look for `lookfor' in `enclosing', return chain of syntaxes from -;; the innermost out of only syntaxes with the given src, returns #f -;; if it can't find it. -(define (enclosing-syntaxes-with-source enclosing lookfor src) - (let loop ([r '()] [stx enclosing]) - ;(printf "stx is ~a\n" (syntax->datum stx)) - ;(printf "source is ~a\n" (syntax-source stx)) - (let* ([r (if (and (syntax? stx) (eq? src (syntax-source stx))) - (cons stx r) - r)] - [loop (lambda (stx) (loop r stx))]) - (if (eq? stx lookfor) - r - (let ([stx (if (syntax? stx) (syntax-e stx) stx)]) - (and (pair? stx) - (or (loop (car stx)) (loop (cdr stx))))))))) - -(define (unwind p) - (if (syntax? p) - (vector (vector (syntax-source p) (syntax-line p)) (unwind (syntax-e p))) - (if (pair? p) - (cons (unwind (car p)) (unwind (cdr p))) - p))) - -;; Look for (the outermost) syntax in `orig' that has the same -;; location as `lookfor' which is coming from the expanded `orig', -;; given in `expanded'. -(define (look-for-in-orig orig expanded lookfor) - (define src (syntax-source orig)) - ;(printf "orig : ~a\n" (unwind orig)) - ;(printf "expanded : ~a\n" expanded) - ;(printf "lookfor : ~a\n" (unwind lookfor)) - ;(printf "src : ~a\n" src) - (let ([enclosing (enclosing-syntaxes-with-source expanded lookfor src)] - [syntax-locs (make-hash)]) - ;; find all syntax locations in original code - (let loop ([stx orig]) - (when (syntax? stx) (hash-set! syntax-locs (syntax-loc stx) stx)) - (let ([stx (if (syntax? stx) (syntax-e stx) stx)]) - (when (pair? stx) (loop (car stx)) (loop (cdr stx))))) - (or - ;; we just might get a lookfor that is already in the original - (and (eq? src (syntax-source lookfor)) - (hash-ref syntax-locs (syntax-loc lookfor) #f) - #;(printf "chose branch one: ~a\n" (hash-ref syntax-locs (syntax-loc lookfor) #f))) - - ;; look for some enclosing expression - (and enclosing - (begin0 - (ormap (lambda (enc) (hash-ref syntax-locs (syntax-loc enc) #f)) - enclosing) - #;(printf "chose branch two ~a\n" enclosing)))))) diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/utils/tc-utils.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/utils/tc-utils.rkt index 5b5eca9c76..0a37babbf1 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/utils/tc-utils.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/utils/tc-utils.rkt @@ -6,7 +6,7 @@ don't depend on any other portion of the system |# (provide (all-defined-out) (all-from-out "disappeared-use.rkt")) -(require "syntax-traversal.rkt" "disappeared-use.rkt" racket/promise +(require syntax/source-syntax "disappeared-use.rkt" racket/promise syntax/parse (for-syntax racket/base syntax/parse) racket/match) ;; a parameter representing the original location of the syntax being @@ -58,15 +58,18 @@ don't depend on any other portion of the system (locate-stx e)) e)))) -(define (locate-stx stx) - (define omodule (orig-module-stx)) - (define emodule (expanded-module-stx)) - ;(printf "orig: ~a\n" (syntax-object->datum omodule)) - ;(printf "exp: ~a\n" (syntax-object->datum emodule)) - ;(printf "stx (locate): ~a\n" (syntax-object->datum stx)) - (if (and (not (print-syntax?)) omodule emodule stx) - (or (look-for-in-orig omodule emodule stx) stx) - stx)) +(define locate-stx + ;; this hash handles using `locate-stx` even when orig/expand change + (let ([recover-table (make-hash)]) + (lambda (stx) + (define omodule (orig-module-stx)) + (define emodule (expanded-module-stx)) + (cond [(and (not (print-syntax?)) omodule emodule stx) + (define recover + (hash-ref! recover-table (cons omodule emodule) + (lambda () (recover-source-syntax omodule emodule)))) + (or (recover stx) stx)] + [else stx])))) (define (raise-typecheck-error msg stxs) (if (null? (cdr stxs)) @@ -93,7 +96,7 @@ don't depend on any other portion of the system [l (let ([stxs (for/list ([e (in-list l)]) - (with-handlers ([exn:fail:syntax? + (with-handlers ([exn:fail:syntax? (λ (e) ((error-display-handler) (exn-message e) e))]) (raise-typecheck-error (err-msg e) (err-stx e))) (err-stx e))])