From 05495764ea51260710fd3a976c93a7eb58b0acb4 Mon Sep 17 00:00:00 2001
From: Matthew Flatt <mflatt@racket-lang.org>
Date: Mon, 23 Jul 2012 07:03:09 -0500
Subject: [PATCH] errortrace: fix profiling for phase >= 2 code

Closes PR 25050

Merge to v5.3
---
 collects/errortrace/stacktrace.rkt            | 41 +++++++++++--------
 collects/tests/errortrace/phase-2-profile.rkt | 19 +++++++++
 2 files changed, 44 insertions(+), 16 deletions(-)
 create mode 100644 collects/tests/errortrace/phase-2-profile.rkt

diff --git a/collects/errortrace/stacktrace.rkt b/collects/errortrace/stacktrace.rkt
index 8abeeb5974..0e057cfb96 100644
--- a/collects/errortrace/stacktrace.rkt
+++ b/collects/errortrace/stacktrace.rkt
@@ -127,16 +127,23 @@
                     [profile-key (datum->syntax
                                   #f profile-key (quote-syntax here))]
                     [register-profile-start register-profile-start]
-                    [register-profile-done register-profile-done])
+                    [register-profile-done register-profile-done]
+                    [app (syntax-shift-phase-level #'#%plain-app (- phase base-phase))]
+                    [lt (syntax-shift-phase-level #'let (- phase base-phase))]
+                    [qt (syntax-shift-phase-level #'quote (- phase base-phase))]
+                    [bgn (syntax-shift-phase-level #'begin (- phase base-phase))]
+                    [wcm (syntax-shift-phase-level #'with-continuation-mark (- phase base-phase))])
         (with-syntax ([rest
                        (insert-at-tail*
-                        (syntax (#%plain-app register-profile-done 'key start))
+                        (syntax (app (qt register-profile-done) (qt key) start))
                         bodies
                         phase)])
           (syntax
-           (let ([start (#%plain-app register-profile-start 'key)])
-             (with-continuation-mark 'profile-key 'key
-               (begin . rest))))))))
+           (lt ([start (app (qt register-profile-start) (qt key))])
+             (wcm 
+              (qt profile-key)
+              (qt key)
+              (bgn . rest))))))))
   
   (define (insert-at-tail* e exprs phase)
     (let ([new
@@ -153,21 +160,23 @@
   
   (define (insert-at-tail se sexpr phase)
     (with-syntax ([expr sexpr]
-                  [e se])
+                  [e se]
+                  [bgn (syntax-shift-phase-level #'begin (- phase base-phase))]
+                  [bgn0 (syntax-shift-phase-level #'begin0 (- phase base-phase))])
       (kernel-syntax-case/phase sexpr phase
         ;; negligible time to eval
         [id
          (identifier? sexpr)
-         (syntax (begin e expr))]
-        [(quote _) (syntax (begin e expr))]
-        [(quote-syntax _) (syntax (begin e expr))]
-        [(#%top . d) (syntax (begin e expr))]
-        [(#%variable-reference . d) (syntax (begin e expr))]
+         (syntax (bgn e expr))]
+        [(quote _) (syntax (bgn e expr))]
+        [(quote-syntax _) (syntax (bgn e expr))]
+        [(#%top . d) (syntax (bgn e expr))]
+        [(#%variable-reference . d) (syntax (bgn e expr))]
         
         ;; No tail effect, and we want to account for the time
-        [(#%plain-lambda . _) (syntax (begin0 expr e))]
-        [(case-lambda . _) (syntax (begin0 expr e))]
-        [(set! . _) (syntax (begin0 expr e))]
+        [(#%plain-lambda . _) (syntax (bgn0 expr e))]
+        [(case-lambda . _) (syntax (bgn0 expr e))]
+        [(set! . _) (syntax (bgn0 expr e))]
         
         [(let-values bindings . body)
          (insert-at-tail* se sexpr phase)]
@@ -182,7 +191,7 @@
          (insert-at-tail* se sexpr phase)]
         
         [(begin0 body ...)
-         (rearm sexpr (syntax (begin0 body ... e)))]
+         (rearm sexpr (syntax (bgn0 body ... e)))]
         
         [(if test then else)
          ;; WARNING: se inserted twice!
@@ -197,7 +206,7 @@
         [(#%plain-app . rest)
          (if (stx-null? (syntax rest))
              ;; null constant
-             (syntax (begin e expr))
+             (syntax (bgn e expr))
              ;; application; exploit guaranteed left-to-right evaluation
              (insert-at-tail* se sexpr phase))]
         
diff --git a/collects/tests/errortrace/phase-2-profile.rkt b/collects/tests/errortrace/phase-2-profile.rkt
new file mode 100644
index 0000000000..976a277244
--- /dev/null
+++ b/collects/tests/errortrace/phase-2-profile.rkt
@@ -0,0 +1,19 @@
+#lang racket/base
+
+(provide phase-2-profile-tests)
+
+(define (phase-2-profile-tests)
+  (define ns (make-base-namespace))
+  (parameterize ([current-namespace ns])
+    (dynamic-require 'errortrace #f)
+    ((dynamic-require 'errortrace 'profiling-enabled) #t)
+    (eval
+     '(module m racket/base
+        (require (for-syntax racket/base))
+        (begin-for-syntax
+         (require (for-syntax racket/base))
+         (define-syntax (a stx)
+           (syntax-case stx () 
+             [(_) #'123])))))))
+
+(phase-2-profile-tests)