From 2aa592eb2e02d0e1f668407f371bb573550a0fce 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. original commit: 1e7eb34ba170b6aad77ee67c0f4b802950ff1a4b --- pkgs/typed-racket-pkgs/source-syntax/info.rkt | 9 ++ .../source-syntax/source-syntax.rkt | 87 +++++++++++++++++++ .../typed-racket-lib/info.rkt | 1 + .../typed-racket/utils/tc-utils.rkt | 25 +++--- 4 files changed, 111 insertions(+), 11 deletions(-) create mode 100644 pkgs/typed-racket-pkgs/source-syntax/info.rkt create mode 100644 pkgs/typed-racket-pkgs/source-syntax/source-syntax.rkt 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 00000000..a0eebe8d --- /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 00000000..199b4a94 --- /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 5dbe4aab..524f6c0f 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/tc-utils.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/utils/tc-utils.rkt index 5b5eca9c..0a37babb 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))])