diff --git a/collects/typed-scheme/optimizer/logging.rkt b/collects/typed-scheme/optimizer/logging.rkt index 06f26eb18b..b9e861ab7b 100644 --- a/collects/typed-scheme/optimizer/logging.rkt +++ b/collects/typed-scheme/optimizer/logging.rkt @@ -1,7 +1,7 @@ #lang racket/base -(require racket/set racket/string racket/match racket/list - unstable/syntax unstable/logging +(require racket/set racket/string racket/match racket/list racket/serialize + unstable/syntax unstable/logging syntax/to-string "../utils/tc-utils.rkt") (provide log-optimization log-missed-optimization @@ -10,7 +10,8 @@ with-intercepted-tr-logging with-tr-logging-to-port (struct-out log-entry) (struct-out opt-log-entry) - (struct-out missed-opt-log-entry)) + (struct-out missed-opt-log-entry) + (struct-out pseudo-syntax)) ;;-------------------------------------------------------------------- @@ -26,11 +27,29 @@ (define log-so-far '()) ;; msg is for consumption by the DrRacket tool -(struct log-entry (kind msg stx located-stx pos) #:prefab) +;; mutability is there only to replace syntax with pseudo-syntax before +;; printing at the end +(struct log-entry (kind msg (stx #:mutable) (located-stx #:mutable) pos) + #:prefab) ;; for optimizations only (not missed optimizations, those are below) (struct opt-log-entry log-entry () #:prefab) +;; syntax objects are not serializable. +;; this is a prefab struct that holds the information we need from syntax +;; objects while still being serializable +;; rep : string (result of syntax->string) +(struct pseudo-syntax (rep line column position span + source-directory source-file-name) + #:prefab) +(define (syntax->pseudo-syntax stx) + (pseudo-syntax (syntax->string #`(#,stx)) ; takes a list of stxs + (syntax-line stx) (syntax-column stx) + (syntax-position stx) (syntax-span stx) + (serialize (syntax-source-directory stx)) + (serialize (syntax-source-file-name stx)))) + + (define (log-optimization kind msg stx) (let ([new-entry (opt-log-entry kind msg @@ -53,7 +72,7 @@ ;; that got merged into this miss. we need to keep them around to detect ;; future potential merges. (struct missed-opt-log-entry log-entry - (irritants merged-irritants badness) + ((irritants #:mutable) (merged-irritants #:mutable) badness) #:prefab) (define missed-optimizations-log '()) @@ -214,8 +233,18 @@ (define logger (current-logger)) (add-missed-opts-to-log) (for ([x (sort-log)]) - (log-message logger 'warning - (format-log-entry x) + (define out (format-log-entry x)) + (set-log-entry-stx! x (syntax->pseudo-syntax (log-entry-stx x))) + (set-log-entry-located-stx! x (syntax->pseudo-syntax + (log-entry-located-stx x))) + (when (missed-opt-log-entry? x) + (set-missed-opt-log-entry-irritants! + x (map syntax->pseudo-syntax + (missed-opt-log-entry-irritants x))) + (set-missed-opt-log-entry-merged-irritants! + x (map syntax->pseudo-syntax + (missed-opt-log-entry-merged-irritants x)))) + (log-message logger 'warning out (cons optimization-log-key x)))) (define (clear-log) diff --git a/collects/typed-scheme/optimizer/tool/display.rkt b/collects/typed-scheme/optimizer/tool/display.rkt index f63f387070..d7f62faf04 100644 --- a/collects/typed-scheme/optimizer/tool/display.rkt +++ b/collects/typed-scheme/optimizer/tool/display.rkt @@ -1,9 +1,10 @@ #lang racket/base (require racket/string racket/class racket/gui/base racket/match racket/port - framework syntax/to-string + framework "report.rkt" - unstable/sequence unstable/pretty) + unstable/sequence unstable/pretty + typed-scheme/optimizer/logging) ; for pseudo-syntax utils (provide popup-callback make-color-table) @@ -32,7 +33,9 @@ ;; the location, the syntax and the message are in separate editors (define location-text (new text:basic% [auto-wrap #t])) - (define location (format "~a:~a:" (syntax-line stx) (syntax-column stx))) + (define location (format "~a:~a:" + (pseudo-syntax-line stx) + (pseudo-syntax-column stx))) (send location-text insert-port (open-input-string location)) (send location-text lock #t) ;; add to the main editor @@ -43,14 +46,14 @@ (define syntax-text (new text:basic%)) ;; typeset the syntax as code (send syntax-text change-style tt-style-delta) - (send syntax-text insert-port - (open-input-string (syntax->string #`(#,stx)))) ; takes a list of stxs + (send syntax-text insert-port (open-input-string (pseudo-syntax-rep stx))) ;; circle irritants, if necessary (when (missed-opt-report-entry? s) (for ([i (in-list (missed-opt-report-entry-irritants s))] - #:when (syntax-position i)) - (define start (- (syntax-position i) (syntax-position stx))) - (define len (syntax-span i)) + #:when (pseudo-syntax-position i)) + (define start (- (pseudo-syntax-position i) + (pseudo-syntax-position stx))) + (define len (pseudo-syntax-span i)) ;; will be off if there are comments inside an irritant (span will be ;; higher than what's actually displayed), but unless we make the ;; located version of irritants available, this is the best we can do diff --git a/collects/typed-scheme/optimizer/tool/report.rkt b/collects/typed-scheme/optimizer/tool/report.rkt index 706664c55d..e72667c8f5 100644 --- a/collects/typed-scheme/optimizer/tool/report.rkt +++ b/collects/typed-scheme/optimizer/tool/report.rkt @@ -1,6 +1,6 @@ #lang racket/base -(require racket/class racket/gui/base racket/match +(require racket/class racket/gui/base racket/match racket/serialize unstable/syntax) (require (prefix-in tr: typed-scheme/typed-reader) @@ -55,11 +55,12 @@ (lambda (l) (define log-entry-data (cdr (vector-ref l 2))) ; log-entry struct (define stx (log-entry-stx log-entry-data)) - (define path (if (and (syntax-source-directory stx) - (syntax-source-file-name stx)) - (build-path (syntax-source-directory stx) - (syntax-source-file-name stx)) - #f)) + (define path + (if (and (pseudo-syntax-source-directory stx) + (pseudo-syntax-source-file-name stx)) + (build-path (deserialize (pseudo-syntax-source-directory stx)) + (deserialize (pseudo-syntax-source-file-name stx))) + #f)) (when (right-file? path) (set! log (cons log-entry-data log)))) (lambda () @@ -75,7 +76,7 @@ (match l [(log-entry kind msg stx located-stx (? number? pos)) (define start (sub1 pos)) - (define end (+ start (syntax-span stx))) + (define end (+ start (pseudo-syntax-span stx))) (report-entry (list (if (opt-log-entry? l) (opt-report-entry located-stx msg) (missed-opt-report-entry