From 05495764ea51260710fd3a976c93a7eb58b0acb4 Mon Sep 17 00:00:00 2001 From: Matthew Flatt 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)