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.

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) 
+      (define expanded-e (expand-syntax e))
-                    (namespace-base-phase)))
+      (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)

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)

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

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)

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

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:

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

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

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

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
+                                    (if do-errortrace
-                                         (continuation-mark-set->context
+                                        (for/list ([frame (in-list
-                                          (continuation-marks t))))
+                                                           (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))]

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/syntax-traversal.rkt

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

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 locate-stx
-  (define omodule (orig-module-stx))
+  ;; this hash handles using `locate-stx` even when orig/expand change
-  (define emodule (expanded-module-stx))
+  (let ([recover-table (make-hash)])
-  ;(printf "orig: ~a\n" (syntax-object->datum omodule))
+    (lambda (stx)
-  ;(printf "exp: ~a\n" (syntax-object->datum emodule))
+      (define omodule (orig-module-stx))
-  ;(printf "stx (locate): ~a\n" (syntax-object->datum stx))
+      (define emodule (expanded-module-stx))
-  (if (and (not (print-syntax?)) omodule emodule stx)
+      (cond [(and (not (print-syntax?)) omodule emodule stx)
-      (or (look-for-in-orig omodule emodule stx) stx)
+	     (define recover
-      stx))
+	       (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))])