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

@@ -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))

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))))))

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"))
 

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))])