diff --git a/collects/typed-scheme/optimizer/logging.rkt b/collects/typed-scheme/optimizer/logging.rkt index 6fea65ef29..c54f4addc3 100644 --- a/collects/typed-scheme/optimizer/logging.rkt +++ b/collects/typed-scheme/optimizer/logging.rkt @@ -6,7 +6,8 @@ (provide log-optimization log-missed-optimization print-log clear-log - with-tr-logging-to-port) + with-intercepted-tr-logging with-tr-logging-to-port + (struct-out log-entry)) (define (line+col->string stx) (let ([line (syntax-line stx)] @@ -15,7 +16,7 @@ (format "~a:~a" line col) "(no location)"))) -(struct log-entry (msg stx pos) #:transparent) +(struct log-entry (msg stx pos) #:prefab) ;; to identify log messages that come from the optimizer ;; to be stored in the data section of log messages @@ -190,13 +191,21 @@ ", ")) kind))) -(define (with-tr-logging-to-port port thunk) - (with-intercepted-logging ; catch opt logs +;; only intercepts TR log messages +(define (with-intercepted-tr-logging interceptor thunk) + (with-intercepted-logging + #:level 'warning (lambda (l) (let ([data (vector-ref l 2)]) ;; look only for optimizer messages (when (and (pair? data) (eq? (car data) optimization-log-key)) - (displayln (vector-ref l 1) port)))) ; print log message - thunk - #:level 'warning)) + (interceptor l)))) + thunk)) + +(define (with-tr-logging-to-port port thunk) + (with-intercepted-tr-logging + #:level 'warning + (lambda (l) + (displayln (vector-ref l 1) port)) ; print log message + thunk)) diff --git a/collects/typed-scheme/optimizer/tool/tool.rkt b/collects/typed-scheme/optimizer/tool/tool.rkt index f31c704f3d..471a65e8ef 100644 --- a/collects/typed-scheme/optimizer/tool/tool.rkt +++ b/collects/typed-scheme/optimizer/tool/tool.rkt @@ -1,6 +1,6 @@ #lang racket/base -(require racket/unit racket/class racket/port +(require racket/unit racket/class racket/port racket/list racket/gui/base mrlib/switchable-button) (require (prefix-in tr: typed-scheme/typed-reader) @@ -29,16 +29,32 @@ (define portname (send defs get-port-name)) (define input (open-input-text-editor defs)) (port-count-lines! input) + (define log '()) + (with-intercepted-tr-logging + (lambda (l) + (set! log (cons (cdr (vector-ref l 2)) ; log-entry struct + log))) + (lambda () + (parameterize ([current-namespace (make-base-namespace)] + [read-accept-reader #t]) + (expand (tr:read-syntax portname input))))) + (set! log (reverse log)) + ;; highlight + (for ([l (in-list log)]) + (let ([stx (log-entry-stx l)] + [pos (sub1 (log-entry-pos l))] + ;; opt or missed opt? + [opt? (regexp-match #rx"^TR opt:" (log-entry-msg l))]) + (send defs highlight-range + pos + (+ pos (syntax-span stx)) + (if opt? "lightgreen" "pink")))) (message-box "Performance Report" (with-output-to-string - (lambda () - (with-tr-logging-to-port - (current-output-port) - (lambda () - (parameterize ([current-namespace (make-base-namespace)] - [read-accept-reader #t]) - (expand (tr:read-syntax portname input))))))))) + (lambda () + (for ([l (in-list log)]) + (displayln (log-entry-msg l))))))) (define performance-report-drracket-button (list